From cf67831cbedd6cf3a6c65d35de6e1c9934b6ba37 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 10 Jan 1998 19:56:32 +0000 Subject: [PATCH 001/466] code unitized and interface sanitized original commit: abdf1b56a7cf0d87cba22e2b4177b9e6398a2da4 --- collects/compiler/sig.ss | 74 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) create mode 100644 collects/compiler/sig.ss diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss new file mode 100644 index 0000000000..8fcf238399 --- /dev/null +++ b/collects/compiler/sig.ss @@ -0,0 +1,74 @@ + +(reference-library "compiles.ss") +(reference-library "makes.ss" "make") +(reference-library "collections.ss" "make") + +;; Compiler options +(define-signature compiler:option^ + (verbose ; default = #f + + setup-prefix ; string to embed in public names; + ; used mainly for compiling extensions + ; with the collection name so that + ; cross-extension conflicts are less + ; likely in architectures that expose + ; the public names of loaded extensions + ; default = "" + + clean-intermediate-files ; #t => keep intermediate .c/.o files + ; default = #f + + propagate-constants ; default = #t + assume-primitives ; #t => car = #%car; default = #f + stupid ; allow obvious non-syntactic errors; + ; e.g.: ((lambda () 0) 1 2 3) + + vehicles ; Controls how closures are compiled: + ; 'vehicles:automatic, + ; 'vehicles:functions, + ; 'vechicles:units, or + ; 'vehicles:monolithic. + ; default = 'vehicles:automatic + vehicles:monoliths ; Size for 'vehicles:monolithic + seed ; Randomizer seed for 'vehicles:monolithic + + max-exprs-per-top-level-set ; Number of top-level Scheme expressions + ; crammed into one C function; default = 25 + + unpack-environments ; default = #t + ; Maybe #f helps for register-poor architectures? + + debug ; #t => creates debug.txt debugging file + test ; #t => ignores top-level expressions with syntax errors + )) + +;; Compiler procedures +(define-signature compiler^ + (compile-extensions + compile-extensions-to-c + compile-c-extensions + + compile-extension-parts + compile-extension-parts-to-c + compile-c-extension-parts + + link-extension-parts + + compile-zos + + compile-collection-extension + compile-collection-zos)) + +;; Low-level extension compiler interface +(define-signature compiler:inner^ + (compile-extension + compile-extension-to-c + compile-c-extension + compile-extension-part + compile-extension-part-to-c + compile-c-extension-part + eval-compile-prefix)) + +;; Low-level multi-file extension linker interface +(define-signature compiler:linker^ + (link-extension)) From 5df833e306f6145c26daa14fd325a72fa03ba4cd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Mar 1998 19:17:19 +0000 Subject: [PATCH 002/466] compile-plt messages original commit: 618228baca2d95496bcaa7a60f123fc3b0f189f8 --- collects/compiler/sig.ss | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 22d86a5201..b05ab2db3e 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -18,6 +18,10 @@ clean-intermediate-files ; #t => keep intermediate .c/.o files ; default = #f + compile-subcollections ; #t => use 'compile-subcollections + ; from infor for collection compiling + ; default = #t + propagate-constants ; default = #t assume-primitives ; #t => car = #%car; default = #f stupid ; allow obvious non-syntactic errors; From bc40d08dc67b4ef65c7d38530293dc4693a698b3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 10 Mar 1998 13:59:40 +0000 Subject: [PATCH 003/466] --embedded, setup-plt refinements for .plt original commit: 9ac24a035bdba22c6212dbfff88e8c2f5b843109 --- collects/compiler/sig.ss | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index b05ab2db3e..a078ad9bf6 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -22,6 +22,10 @@ ; from infor for collection compiling ; default = #t + compile-for-embedded ; #f => make objects to be linked + ; directly with MzScheme, not dynamically + ; loaded; default = #f + propagate-constants ; default = #t assume-primitives ; #t => car = #%car; default = #f stupid ; allow obvious non-syntactic errors; From 536f87f7c1b29ded331e57a889a1feac46f0704d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Mar 1998 19:34:50 +0000 Subject: [PATCH 004/466] mrspidey integration original commit: a0750d913741390cd5aec93ddb9c19cdd4e0e569 --- collects/compiler/sig.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index a078ad9bf6..7b6ebfa471 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -15,6 +15,9 @@ ; the public names of loaded extensions ; default = "" + use-mrspidey ; #t => analyze with MrSpidey + ; default = #f + clean-intermediate-files ; #t => keep intermediate .c/.o files ; default = #f From 3aad0a15391b7b27b6474fb6c98d96518d0ae014 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Apr 1998 14:56:52 +0000 Subject: [PATCH 005/466] reference -> require, etc. original commit: 221d609dd7ecdfd8cf12a75cfd8ecbfcd3799972 --- collects/compiler/sig.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 7b6ebfa471..8b258781aa 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -1,7 +1,7 @@ -(reference-library "compiles.ss") -(reference-library "makes.ss" "make") -(reference-library "collections.ss" "make") +(require-library "compiles.ss") +(require-library "makes.ss" "make") +(require-library "collections.ss" "make") ;; Compiler options (define-signature compiler:option^ From 52ea5b868a93b2c36a0682594938ada4cdc0b435 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 May 1998 21:58:38 +0000 Subject: [PATCH 006/466] refinements to calling convention, ad hoc optimizations and primitive inlining original commit: 979a3270e0eea63dfe933fd47dcf1f54488cb7a9 --- collects/compiler/sig.ss | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 8b258781aa..9d6a3c42a1 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -15,9 +15,12 @@ ; the public names of loaded extensions ; default = "" - use-mrspidey ; #t => analyze with MrSpidey + use-mrspidey ; #t => whole-program analyze with MrSpidey ; default = #f + use-mrspidey-for-units ; #t => per-unit analyze with MrSpidey + ; default = #f + clean-intermediate-files ; #t => keep intermediate .c/.o files ; default = #f From 4ca4d82a7509fc3ff8678cc4de3641a009f851c9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 May 1998 22:01:23 +0000 Subject: [PATCH 007/466] separated known-variable analysis phase, added inlining original commit: 5d7647b40bdfe8ee588490759f20388751b18c3a --- collects/compiler/sig.ss | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 9d6a3c42a1..7839a8694d 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -32,6 +32,8 @@ ; directly with MzScheme, not dynamically ; loaded; default = #f + max-inline-size ; max size of inlined procedures + propagate-constants ; default = #t assume-primitives ; #t => car = #%car; default = #f stupid ; allow obvious non-syntactic errors; From 8155b8485a28d0d344443028e077df5ff1bb3d65 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 6 Sep 1998 02:17:49 +0000 Subject: [PATCH 008/466] . original commit: 93c62f704093eba91fd34f5bfc22e7daa32484a2 --- collects/compiler/sig.ss | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 7839a8694d..e268f43852 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -21,6 +21,10 @@ use-mrspidey-for-units ; #t => per-unit analyze with MrSpidey ; default = #f + lightweight ; #t => perform lightweight closure conversion + ; on MrSpidey-analyzed code + ; default = #t + clean-intermediate-files ; #t => keep intermediate .c/.o files ; default = #f From 5800483dfd7d82d991c0f6aa44c91b43abae0fd2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Oct 1998 16:16:44 +0000 Subject: [PATCH 009/466] . original commit: cc9de5c6e96ecc1ce364290bb02d387b963a19a5 --- collects/compiler/sig.ss | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index e268f43852..f132c86afc 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -38,6 +38,15 @@ max-inline-size ; max size of inlined procedures + disable-interrupts ; #t => UNSAFE: turn off breaking, stack + ; overflow, and thread switching; + ; default = #f + unsafe ; #t => UNSAFE: omit some type checks + ; default = #f + fixnum-arithmetic ; #t => UNSAFE: don't check for overflow or + ; underflow for fixnum arithmetic; + ; default = #f + propagate-constants ; default = #t assume-primitives ; #t => car = #%car; default = #f stupid ; allow obvious non-syntactic errors; From 2b359890120d68652554ef7ab76eac7ee2c1fced Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 13 Oct 1998 22:38:20 +0000 Subject: [PATCH 010/466] . original commit: a6b9a807b7287a4085058a3995ba325b406c7ef5 --- collects/compiler/sig.ss | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index f132c86afc..25ebf6b4ce 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -21,9 +21,8 @@ use-mrspidey-for-units ; #t => per-unit analyze with MrSpidey ; default = #f - lightweight ; #t => perform lightweight closure conversion - ; on MrSpidey-analyzed code - ; default = #t + lightweight ; #t => perform lightweight closure conversion; + ; default = #f clean-intermediate-files ; #t => keep intermediate .c/.o files ; default = #f From f4c9a0b4e708f0d359d38998b873c9e231e4f5af Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 28 Nov 1998 04:54:42 +0000 Subject: [PATCH 011/466] unitized setup-plt original commit: 10d45a71f2765e8ef31b3d61385d173d206f8b55 --- collects/compiler/sig.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 25ebf6b4ce..66a5202f14 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -1,7 +1,8 @@ -(require-library "compiles.ss") -(require-library "makes.ss" "make") -(require-library "collections.ss" "make") +(begin-elaboration-time + (require-library "compiles.ss") + (require-library "makes.ss" "make") + (require-library "collections.ss" "make")) ;; Compiler options (define-signature compiler:option^ From 932f8b3bbc79777ee2616a324b86c6bfd1ad7f82 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 8 Sep 2000 16:30:40 +0000 Subject: [PATCH 012/466] ... original commit: 1f4f8cc40600597d59a6bba1b4ee6b25cfb3faf2 --- collects/compiler/sig.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 28be96a258..609b0bf627 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -3,7 +3,8 @@ (require-library "compiles.ss") (require-library "inflates.ss") (require-library "makes.ss" "make") - (require-library "collections.ss" "make")) + (require-library "collections.ss" "make") + (require-library "get-infos.ss" "setup")) ;; Compiler options (define-signature compiler:option^ From 186baf4aa3fc50f494559878fe4777369afb621e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Feb 2001 04:32:15 +0000 Subject: [PATCH 013/466] . original commit: 3384bad85dd51d8467e75edcb4eeb9e68bce46cf --- collects/launcher/launcher-sig.ss | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 collects/launcher/launcher-sig.ss diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss new file mode 100644 index 0000000000..386d013d95 --- /dev/null +++ b/collects/launcher/launcher-sig.ss @@ -0,0 +1,19 @@ + +(module launcher-sig mzscheme + (import (lib "unitsig.ss")) + + (export launcher-maker^) + + (define-signature launcher-maker^ + (make-mred-launcher + make-mzscheme-launcher + + make-mred-program-launcher + make-mzscheme-program-launcher + + mred-program-launcher-path + mzscheme-program-launcher-path + + install-mred-program-launcher + install-mzscheme-program-launcher))) + From b59f6273b0f7f023012d0003774d4027cc0f8f24 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Feb 2001 04:02:24 +0000 Subject: [PATCH 014/466] . original commit: 829c62c8f612efda004a0babe3140ba7aff70167 --- collects/setup/sig.ss | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 collects/setup/sig.ss diff --git a/collects/setup/sig.ss b/collects/setup/sig.ss new file mode 100644 index 0000000000..8249020cee --- /dev/null +++ b/collects/setup/sig.ss @@ -0,0 +1,18 @@ + +(module sig mzscheme + (import (lib "unitsig.ss")) + + (export setup-option^) + + (define-signature setup-option^ + (verbose + make-verbose + compiler-verbose + clean + make-zo + make-so + make-launchers + call-install + pause-on-errors + specific-collections + archives))) From d5424211cb9883fe41d751785cea6c77a872486b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Feb 2001 19:52:06 +0000 Subject: [PATCH 015/466] . original commit: 2b7c3fdc298ff2796c76f81cce3129f8ea7ea2ac --- collects/compiler/sig.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 280e7de422..e9ccc6b2a3 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -3,13 +3,13 @@ (import (lib "unitsig.ss")) - (export compiler:options^ + (export compiler:option^ compiler^ compiler:inner^ compiler:linker^) ;; Compiler options - (define-signature compiler:options^ + (define-signature compiler:option^ (verbose ; default = #f setup-prefix ; string to embed in public names; From dd45c9344807b63c9eb7f36e1469c3d38a0c8bf6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 13 Feb 2001 22:07:07 +0000 Subject: [PATCH 016/466] . original commit: 8e98d4273663a0ca7c005ae170b7048da5c723f7 --- collects/setup/{sig.ss => option-sig.ss} | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) rename collects/setup/{sig.ss => option-sig.ss} (91%) diff --git a/collects/setup/sig.ss b/collects/setup/option-sig.ss similarity index 91% rename from collects/setup/sig.ss rename to collects/setup/option-sig.ss index 8249020cee..780485d8e0 100644 --- a/collects/setup/sig.ss +++ b/collects/setup/option-sig.ss @@ -1,5 +1,5 @@ -(module sig mzscheme +(module option-sig mzscheme (import (lib "unitsig.ss")) (export setup-option^) From 08e1bc7f5fb5efa44476d7faaba04a7aa21a4e3c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Feb 2001 23:10:50 +0000 Subject: [PATCH 017/466] . original commit: a7432874af0d8e8175b449832d45abee2b42fb99 --- collects/compiler/sig.ss | 4 ++-- collects/setup/option-sig.ss | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index e9ccc6b2a3..2830333fca 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -1,9 +1,9 @@ (module sig mzscheme - (import (lib "unitsig.ss")) + (require (lib "unitsig.ss")) - (export compiler:option^ + (provide compiler:option^ compiler^ compiler:inner^ compiler:linker^) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 780485d8e0..b7905a046e 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -1,8 +1,8 @@ (module option-sig mzscheme - (import (lib "unitsig.ss")) + (require (lib "unitsig.ss")) - (export setup-option^) + (provide setup-option^) (define-signature setup-option^ (verbose From fd5b880c0cfb844c34761f27802d85c8724d3c26 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 15 Feb 2001 04:15:23 +0000 Subject: [PATCH 018/466] . original commit: f3ac2fc5f710dbf1e140978711cfa24411c6749b --- collects/launcher/launcher-sig.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index 386d013d95..b707819ea0 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -1,8 +1,8 @@ (module launcher-sig mzscheme - (import (lib "unitsig.ss")) + (require (lib "unitsig.ss")) - (export launcher-maker^) + (provide launcher-maker^) (define-signature launcher-maker^ (make-mred-launcher From b917d67cde4e632723f13db6767054a87b1c35d5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 18 Feb 2001 05:25:49 +0000 Subject: [PATCH 019/466] . original commit: 5af0fe07e9d33c7dc831aee179bd8bdd02f87c43 --- collects/launcher/launcher-sig.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index b707819ea0..50b5d11ffa 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -2,9 +2,9 @@ (module launcher-sig mzscheme (require (lib "unitsig.ss")) - (provide launcher-maker^) + (provide launcher^) - (define-signature launcher-maker^ + (define-signature launcher^ (make-mred-launcher make-mzscheme-launcher From 2614f4064c621f5cc737d24f0ac5d6b97b5b4cf8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Jun 2001 07:42:27 +0000 Subject: [PATCH 020/466] . original commit: 91dcb209a3b0f88e0589eb80de529d84ed607ed8 --- collects/compiler/sig.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 2830333fca..51db3b9df6 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -4,9 +4,9 @@ (require (lib "unitsig.ss")) (provide compiler:option^ - compiler^ - compiler:inner^ - compiler:linker^) + compiler^ + compiler:inner^ + compiler:linker^) ;; Compiler options (define-signature compiler:option^ From 32cc78b2c8b4e45bc2973817db06837d131f5b4f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 13 Sep 2001 22:42:56 +0000 Subject: [PATCH 021/466] . original commit: 1f7dc0cfc45cda4d181a049246dd720cc135d67d --- collects/compiler/sig.ss | 9 --------- 1 file changed, 9 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 51db3b9df6..15d212d7fb 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -20,15 +20,6 @@ ; the public names of loaded extensions ; default = "" - use-mrspidey ; #t => whole-program analyze with MrSpidey - ; default = #f - - use-mrspidey-for-units ; #t => per-unit analyze with MrSpidey - ; default = #f - - lightweight ; #t => perform lightweight closure conversion; - ; default = #f - clean-intermediate-files ; #t => keep intermediate .c/.o files ; default = #f From 139f8c8e153ff857d49cdb6e739e771dca3db831 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 11 Dec 2001 13:50:43 +0000 Subject: [PATCH 022/466] . original commit: 00fe47d759f949e4e89a80ce49745428ba6c2c56 --- collects/compiler/sig.ss | 2 -- 1 file changed, 2 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 15d212d7fb..0cd9fb8f4e 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -64,8 +64,6 @@ debug ; #t => creates debug.txt debugging file test ; #t => ignores top-level expressions with syntax errors - - zo-compiler-flags )) ;; Compiler procedures From 0535cf3a07806276d0cd378f777b85eac1b92a7f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 13 Dec 2001 00:31:26 +0000 Subject: [PATCH 023/466] . original commit: bd95838e0bceb14923f286ece768a550f4054f96 --- collects/setup/option-sig.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index b7905a046e..3d4b1c9d67 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -15,4 +15,5 @@ call-install pause-on-errors specific-collections - archives))) + archives + current-target-directory-getter))) From 6873e8698af6e028968d0a5c25010b87175db80a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Feb 2002 16:49:19 +0000 Subject: [PATCH 024/466] . original commit: 9bc7798466eea7038de54c2b972b3349bae71a2e --- collects/launcher/launcher-sig.ss | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index 50b5d11ffa..689b354a95 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -15,5 +15,8 @@ mzscheme-program-launcher-path install-mred-program-launcher - install-mzscheme-program-launcher))) + install-mzscheme-program-launcher + current-launcher-variant + available-mred-variants + available-mzscheme-variants))) From f1bdba38c941b89b05b96794842cc99c2df3df4c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Feb 2002 15:29:49 +0000 Subject: [PATCH 025/466] . original commit: 42c4b63ce6f71bd6f0be1ae100c4085a132f1b8b --- collects/setup/option-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 3d4b1c9d67..c9b2d0a9f7 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -14,6 +14,7 @@ make-launchers call-install pause-on-errors + force-unpacks specific-collections archives current-target-directory-getter))) From bd8a40ca73d62ce67f2b6432706d4091a8311fef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Jul 2002 13:33:12 +0000 Subject: [PATCH 026/466] . original commit: a255af5680643ffa33d095df4643d37fef5d04ff --- collects/launcher/launcher-sig.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index 689b354a95..6101935a3e 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -17,6 +17,9 @@ install-mred-program-launcher install-mzscheme-program-launcher + mred-launcher-up-to-date? + mzscheme-launcher-up-to-date? + current-launcher-variant available-mred-variants available-mzscheme-variants))) From 9c6da083e43070825c60c9ed36d0224abff76463 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 7 Jul 2002 19:37:36 +0000 Subject: [PATCH 027/466] . original commit: 2bfdfedacaa0fd044ca6198ebb8074d61fd38b6a --- collects/launcher/launcher-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index 6101935a3e..3ead958040 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -20,6 +20,7 @@ mred-launcher-up-to-date? mzscheme-launcher-up-to-date? + build-aux-from-path current-launcher-variant available-mred-variants available-mzscheme-variants))) From 5b9c560b66f02653bac679c039e53fe1d9420da5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Jul 2002 17:38:21 +0000 Subject: [PATCH 028/466] . original commit: a658fb078bc5be92ffb40d494d8587d3eae68e62 --- collects/launcher/launcher-sig.ss | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index 3ead958040..b126afe7c2 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -20,6 +20,12 @@ mred-launcher-up-to-date? mzscheme-launcher-up-to-date? + mred-launcher-is-directory? + mzscheme-launcher-is-directory? + + mred-launcher-put-file-extension+style+filters + mzscheme-launcher-put-file-extension+style+filters + build-aux-from-path current-launcher-variant available-mred-variants From d6b1760d68c03ae4bd44d5f882fcd3066403149f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Jul 2002 19:29:17 +0000 Subject: [PATCH 029/466] . original commit: 57f20a123d9b8863400b5be181b0990b0c6d2f42 --- collects/compiler/embed-sig.ss | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 collects/compiler/embed-sig.ss diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss new file mode 100644 index 0000000000..ce20d92c21 --- /dev/null +++ b/collects/compiler/embed-sig.ss @@ -0,0 +1,9 @@ + +(module embed-sig mzscheme + (require (lib "unitsig.ss")) + (provide compiler:embed^) + + (define-signature compiler:embed^ + (make-embedding-executable + embedding-executable-is-directory? + embedding-executable-put-file-extension+style+filters))) From a0c61748684b2106aff669274bf36d1e2405f76d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 10 Jul 2003 20:16:56 +0000 Subject: [PATCH 030/466] . original commit: f679606ba8c40ccbf28909c2f3fd5e16f69b3e89 --- collects/setup/option-sig.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index c9b2d0a9f7..ed83caa00b 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -17,4 +17,5 @@ force-unpacks specific-collections archives - current-target-directory-getter))) + current-target-directory-getter + current-target-plt-directory-getter))) From ab0ec8ef5db1a1e60cdfe22a7074eb621f534639 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Jan 2004 17:02:01 +0000 Subject: [PATCH 031/466] . original commit: 399914bda290b094aaa05a92107f4e4969f446bd --- collects/compiler/sig.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 0cd9fb8f4e..70967deaf4 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -82,7 +82,9 @@ compile-zos compile-collection-extension - compile-collection-zos)) + compile-collection-zos + + current-compiler-dynamic-require-namespace)) ;; Low-level extension compiler interface (define-signature compiler:inner^ From dceefe60b7f0aa60d71009518ee367feb2084b32 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Feb 2004 20:35:34 +0000 Subject: [PATCH 032/466] . original commit: 8ce11627dc7aa32453bdc564d8134d6a2a242ee4 --- collects/compiler/sig.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 70967deaf4..5ab84a6037 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -84,7 +84,8 @@ compile-collection-extension compile-collection-zos - current-compiler-dynamic-require-namespace)) + current-compiler-dynamic-require-namespace + compile-notify-handler)) ;; Low-level extension compiler interface (define-signature compiler:inner^ From 6fe4561fa3b12d222206188b17dfb775f56c8c29 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 15 Apr 2004 01:00:12 +0000 Subject: [PATCH 033/466] . original commit: 28442ed79b360ffd8dac05393c3547e544b05df7 --- collects/compiler/sig.ss | 2 +- collects/setup/option-sig.ss | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 5ab84a6037..6256a711e7 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -84,7 +84,7 @@ compile-collection-extension compile-collection-zos - current-compiler-dynamic-require-namespace + current-compiler-dynamic-require-wrapper compile-notify-handler)) ;; Low-level extension compiler interface diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index ed83caa00b..d7ebeb3f24 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -9,6 +9,7 @@ make-verbose compiler-verbose clean + compile-mode make-zo make-so make-launchers From 0eb3014db9270d9db9bfece0161b45d335db0e3d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Sep 2004 22:43:55 +0000 Subject: [PATCH 034/466] . original commit: 4b39999335910713785cb515f42be7b8704ad844 --- collects/setup/option-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index d7ebeb3f24..c8040aa556 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -12,6 +12,7 @@ compile-mode make-zo make-so + make-info-domain make-launchers call-install pause-on-errors From e2730ac1369e06548331e796d09d0095bf00db0a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Oct 2004 19:32:38 +0000 Subject: [PATCH 035/466] . original commit: 3e00c5e728058e06395f24f1c619b0e149902150 --- collects/compiler/embed-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss index ce20d92c21..16c593fe79 100644 --- a/collects/compiler/embed-sig.ss +++ b/collects/compiler/embed-sig.ss @@ -5,5 +5,6 @@ (define-signature compiler:embed^ (make-embedding-executable + write-module-bundle embedding-executable-is-directory? embedding-executable-put-file-extension+style+filters))) From 8030d5c63b5b5ab9ffaa6e88ef609f73097f5072 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2004 12:34:06 +0000 Subject: [PATCH 036/466] . original commit: 496cc6747d89286ee1b25ff0412f651ba8e56b9e --- collects/tests/mzscheme/embed-me1.ss | 2 + collects/tests/mzscheme/embed-me2.ss | 6 ++ collects/tests/mzscheme/embed-me3.ss | 3 + collects/tests/mzscheme/embed-me4.ss | 1 + collects/tests/mzscheme/embed.ss | 139 +++++++++++++++++++++++++++ 5 files changed, 151 insertions(+) create mode 100644 collects/tests/mzscheme/embed-me1.ss create mode 100644 collects/tests/mzscheme/embed-me2.ss create mode 100644 collects/tests/mzscheme/embed-me3.ss create mode 100644 collects/tests/mzscheme/embed-me4.ss create mode 100644 collects/tests/mzscheme/embed.ss diff --git a/collects/tests/mzscheme/embed-me1.ss b/collects/tests/mzscheme/embed-me1.ss new file mode 100644 index 0000000000..5303b9f40e --- /dev/null +++ b/collects/tests/mzscheme/embed-me1.ss @@ -0,0 +1,2 @@ +(module embed-me1 mzscheme + (printf "This is 1~n")) diff --git a/collects/tests/mzscheme/embed-me2.ss b/collects/tests/mzscheme/embed-me2.ss new file mode 100644 index 0000000000..f445236a3e --- /dev/null +++ b/collects/tests/mzscheme/embed-me2.ss @@ -0,0 +1,6 @@ +(module embed-me2 mzscheme + (require "embed-me1.ss" + (lib "etc.ss")) + (printf "This is 2: ~a~n" true)) + + diff --git a/collects/tests/mzscheme/embed-me3.ss b/collects/tests/mzscheme/embed-me3.ss new file mode 100644 index 0000000000..a65072db61 --- /dev/null +++ b/collects/tests/mzscheme/embed-me3.ss @@ -0,0 +1,3 @@ +(module embed-me3 mzscheme + (require (lib "etc.ss")) + (printf "3 is here, too? ~a\n" true)) diff --git a/collects/tests/mzscheme/embed-me4.ss b/collects/tests/mzscheme/embed-me4.ss new file mode 100644 index 0000000000..f2585bee92 --- /dev/null +++ b/collects/tests/mzscheme/embed-me4.ss @@ -0,0 +1 @@ +(printf "This is the literal expression 4.\n") diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss new file mode 100644 index 0000000000..56af478aa8 --- /dev/null +++ b/collects/tests/mzscheme/embed.ss @@ -0,0 +1,139 @@ + +(load-relative "loadtest.ss") + +(SECTION 'embed) + +(require (lib "embed.ss" "compiler") + (lib "process.ss")) + +(define (mk-dest mred?) + (build-path (find-system-path 'temp-dir) + (case (system-type) + [(windows) "e.exe"] + [(unix) "e"] + [(macosx) (if mred? + "e.app" + "e")]))) + +(define mz-dest (mk-dest #f)) +(define mr-dest (mk-dest #t)) + +(define (prepare exe src) + (printf "Making ~a with ~a...~n" exe src) + (when (file-exists? exe) + (delete-file exe))) + +(define (try-exe exe expect) + (let ([out (open-output-bytes)] + [in (open-input-bytes #"")]) + (parameterize ([current-output-port out] + [current-input-port in]) + (system* exe)) + (test expect get-output-string out))) + + +(define (mz-tests mred?) + (define (one-mz-test filename expect) + ;; Try simple mode: one module, launched from cmd line: + (prepare mz-dest filename) + (make-embedding-executable + mz-dest mred? #f + `((#t (lib ,filename "tests" "mzscheme"))) + null + null + `("-mvqL" ,filename "tests/mzscheme")) + (try-exe mz-dest expect) + + ;; Try explicit prefix: + (let ([w/prefix + (lambda (pfx) + (prepare mz-dest filename) + (make-embedding-executable + mz-dest mred? #f + `((,pfx (lib ,filename "tests" "mzscheme"))) + null + null + `("-mvqe" ,(format "(require ~a~a)" + (or pfx "") + (regexp-replace #rx"[.].*$" filename "")))) + (try-exe mz-dest expect))]) + (w/prefix #f) + (w/prefix 'before:)) + + ;; Try full path, and use literal S-exp to start + (prepare mz-dest filename) + (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (make-embedding-executable + mz-dest mred? #f + `((#t ,path)) + null + `(require (file ,(path->string path))) + `("-mvq"))) + (try-exe mz-dest expect) + + ;; Use `file' form: + (prepare mz-dest filename) + (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (make-embedding-executable + mz-dest mred? #f + `((#t (file ,(path->string path)))) + null + `(require (file ,(path->string path))) + `("-mvq"))) + (try-exe mz-dest expect) + + ;; Use relative path + (prepare mz-dest filename) + (parameterize ([current-directory (collection-path "tests" "mzscheme")]) + (make-embedding-executable + mz-dest mred? #f + `((#f ,filename)) + null + `(require ,(string->symbol (regexp-replace #rx"[.].*$" filename ""))) + `("-mvq"))) + (try-exe mz-dest expect) + + ;; Try multiple modules + (prepare mz-dest filename) + (make-embedding-executable + mz-dest mred? #f + `((#t (lib ,filename "tests" "mzscheme")) + (#t (lib "embed-me3.ss" "tests" "mzscheme"))) + null + `(begin + (require (lib "embed-me3.ss" "tests" "mzscheme")) + (require (lib ,filename "tests" "mzscheme"))) + `("-mvq")) + (try-exe mz-dest (string-append "3 is here, too? #t\n" expect)) + + ;; Try a literal file + (prepare mz-dest filename) + (make-embedding-executable + mz-dest mred? #f + `((#t (lib ,filename "tests" "mzscheme"))) + (list (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) + `(begin (display "... and more!\n")) + `("-mvqL" ,filename "tests/mzscheme")) + (try-exe mz-dest (string-append + "This is the literal expression 4.\n" + "... and more!\n" + expect))) + + (one-mz-test "embed-me1.ss" "This is 1\n") + (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n") + + ;; Try unicode expr and cmdline: + (prepare mz-dest "unicode") + (make-embedding-executable + mz-dest #f #f + null + null + `(printf "\uA9, \u7238, and \U1D670\n") + `("-mvqe" "(display \"\u7237...\U1D671\n\")")) + (try-exe mz-dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n")) + + +(mz-tests #f) +(mz-tests #t) + +(report-errs) From bd5e28414508fa2b6a5a7a2879d2184da525d291 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2004 14:26:06 +0000 Subject: [PATCH 037/466] . original commit: dfa1a3dd98fbd43f3476fd4dc4327b583d632c27 --- collects/tests/mzscheme/embed-me5.ss | 3 ++ collects/tests/mzscheme/embed.ss | 60 ++++++++++++++++------------ 2 files changed, 37 insertions(+), 26 deletions(-) create mode 100644 collects/tests/mzscheme/embed-me5.ss diff --git a/collects/tests/mzscheme/embed-me5.ss b/collects/tests/mzscheme/embed-me5.ss new file mode 100644 index 0000000000..690af08111 --- /dev/null +++ b/collects/tests/mzscheme/embed-me5.ss @@ -0,0 +1,3 @@ +(module embed-me5 mzscheme + (require (lib "mred.ss" "mred")) + (printf "This is 5: ~s\n" button%)) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 56af478aa8..517461fc2d 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -31,72 +31,72 @@ (system* exe)) (test expect get-output-string out))) - (define (mz-tests mred?) + (define dest (if mred? mr-dest mz-dest)) (define (one-mz-test filename expect) ;; Try simple mode: one module, launched from cmd line: - (prepare mz-dest filename) + (prepare dest filename) (make-embedding-executable - mz-dest mred? #f + dest mred? #f `((#t (lib ,filename "tests" "mzscheme"))) null null `("-mvqL" ,filename "tests/mzscheme")) - (try-exe mz-dest expect) + (try-exe dest expect) ;; Try explicit prefix: (let ([w/prefix (lambda (pfx) - (prepare mz-dest filename) + (prepare dest filename) (make-embedding-executable - mz-dest mred? #f + dest mred? #f `((,pfx (lib ,filename "tests" "mzscheme"))) null null `("-mvqe" ,(format "(require ~a~a)" (or pfx "") (regexp-replace #rx"[.].*$" filename "")))) - (try-exe mz-dest expect))]) + (try-exe dest expect))]) (w/prefix #f) (w/prefix 'before:)) ;; Try full path, and use literal S-exp to start - (prepare mz-dest filename) + (prepare dest filename) (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) (make-embedding-executable - mz-dest mred? #f + dest mred? #f `((#t ,path)) null `(require (file ,(path->string path))) `("-mvq"))) - (try-exe mz-dest expect) + (try-exe dest expect) ;; Use `file' form: - (prepare mz-dest filename) + (prepare dest filename) (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) (make-embedding-executable - mz-dest mred? #f + dest mred? #f `((#t (file ,(path->string path)))) null `(require (file ,(path->string path))) `("-mvq"))) - (try-exe mz-dest expect) + (try-exe dest expect) ;; Use relative path - (prepare mz-dest filename) + (prepare dest filename) (parameterize ([current-directory (collection-path "tests" "mzscheme")]) (make-embedding-executable - mz-dest mred? #f + dest mred? #f `((#f ,filename)) null `(require ,(string->symbol (regexp-replace #rx"[.].*$" filename ""))) `("-mvq"))) - (try-exe mz-dest expect) + (try-exe dest expect) ;; Try multiple modules - (prepare mz-dest filename) + (prepare dest filename) (make-embedding-executable - mz-dest mred? #f + dest mred? #f `((#t (lib ,filename "tests" "mzscheme")) (#t (lib "embed-me3.ss" "tests" "mzscheme"))) null @@ -104,17 +104,17 @@ (require (lib "embed-me3.ss" "tests" "mzscheme")) (require (lib ,filename "tests" "mzscheme"))) `("-mvq")) - (try-exe mz-dest (string-append "3 is here, too? #t\n" expect)) + (try-exe dest (string-append "3 is here, too? #t\n" expect)) ;; Try a literal file - (prepare mz-dest filename) + (prepare dest filename) (make-embedding-executable - mz-dest mred? #f + dest mred? #f `((#t (lib ,filename "tests" "mzscheme"))) (list (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) `(begin (display "... and more!\n")) `("-mvqL" ,filename "tests/mzscheme")) - (try-exe mz-dest (string-append + (try-exe dest (string-append "This is the literal expression 4.\n" "... and more!\n" expect))) @@ -123,17 +123,25 @@ (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n") ;; Try unicode expr and cmdline: - (prepare mz-dest "unicode") + (prepare dest "unicode") (make-embedding-executable - mz-dest #f #f + dest #f #f null null `(printf "\uA9, \u7238, and \U1D670\n") `("-mvqe" "(display \"\u7237...\U1D671\n\")")) - (try-exe mz-dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n")) - + (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n")) (mz-tests #f) (mz-tests #t) +(prepare mr-dest "embed-me5.ss") +(make-embedding-executable + mr-dest #t #f + `((#t (lib "embed-me5.ss" "tests" "mzscheme"))) + null + null + `("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) +(try-exe mr-dest "This is 5: #\n") + (report-errs) From 9d4deab7b54e5c9b79503a6aa4266e482856e0ec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2004 14:34:08 +0000 Subject: [PATCH 038/466] . original commit: 40054e84125e6a57fbd8d49eb43abb606841a911 --- collects/tests/mzscheme/embed.ss | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 517461fc2d..4da9fa5e4c 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -25,10 +25,22 @@ (define (try-exe exe expect) (let ([out (open-output-bytes)] - [in (open-input-bytes #"")]) + [in (open-input-bytes #"")] + [plthome (getenv "PLTHOME")] + [collects (getenv "PLTCOLLECTS")]) + ;; Try to hide usual collections: + (when plthome + (putenv "PLTHOME" (path->string (find-system-path 'temp-dir)))) + (when collects + (putenv "PLTCOLLECTS" (path->string (find-system-path 'temp-dir)))) + ;; Execute: (parameterize ([current-output-port out] [current-input-port in]) (system* exe)) + (when plthome + (putenv "PLTHOME" plthome)) + (when collects + (putenv "PLTCOLLECTS" "")) (test expect get-output-string out))) (define (mz-tests mred?) From a10cebff2e7fb98157737363d69aa8485e33f364 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2004 16:01:00 +0000 Subject: [PATCH 039/466] . original commit: 3044c9a11598f23f13b14764d441124815d71d55 --- collects/tests/mzscheme/embed-me1.ss | 5 ++- collects/tests/mzscheme/embed-me2.ss | 5 ++- collects/tests/mzscheme/embed-me3.ss | 6 ++- collects/tests/mzscheme/embed-me4.ss | 5 ++- collects/tests/mzscheme/embed-me5.ss | 5 ++- collects/tests/mzscheme/embed.ss | 64 ++++++++++++++++------------ 6 files changed, 58 insertions(+), 32 deletions(-) diff --git a/collects/tests/mzscheme/embed-me1.ss b/collects/tests/mzscheme/embed-me1.ss index 5303b9f40e..7e2bb11748 100644 --- a/collects/tests/mzscheme/embed-me1.ss +++ b/collects/tests/mzscheme/embed-me1.ss @@ -1,2 +1,5 @@ (module embed-me1 mzscheme - (printf "This is 1~n")) + (with-output-to-file "stdout" + (lambda () (printf "This is 1~n")) + 'append)) + diff --git a/collects/tests/mzscheme/embed-me2.ss b/collects/tests/mzscheme/embed-me2.ss index f445236a3e..f0216b0381 100644 --- a/collects/tests/mzscheme/embed-me2.ss +++ b/collects/tests/mzscheme/embed-me2.ss @@ -1,6 +1,9 @@ (module embed-me2 mzscheme (require "embed-me1.ss" (lib "etc.ss")) - (printf "This is 2: ~a~n" true)) + (with-output-to-file "stdout" + (lambda () (printf "This is 2: ~a~n" true)) + 'append)) + diff --git a/collects/tests/mzscheme/embed-me3.ss b/collects/tests/mzscheme/embed-me3.ss index a65072db61..a68cf78d4a 100644 --- a/collects/tests/mzscheme/embed-me3.ss +++ b/collects/tests/mzscheme/embed-me3.ss @@ -1,3 +1,7 @@ (module embed-me3 mzscheme (require (lib "etc.ss")) - (printf "3 is here, too? ~a\n" true)) + (with-output-to-file "stdout" + (lambda () + (printf "3 is here, too? ~a\n" true)) + 'append)) + diff --git a/collects/tests/mzscheme/embed-me4.ss b/collects/tests/mzscheme/embed-me4.ss index f2585bee92..24e22b0787 100644 --- a/collects/tests/mzscheme/embed-me4.ss +++ b/collects/tests/mzscheme/embed-me4.ss @@ -1 +1,4 @@ -(printf "This is the literal expression 4.\n") +(with-output-to-file "stdout" + (lambda () (printf "This is the literal expression 4.\n")) + 'append) + diff --git a/collects/tests/mzscheme/embed-me5.ss b/collects/tests/mzscheme/embed-me5.ss index 690af08111..aaf471f21f 100644 --- a/collects/tests/mzscheme/embed-me5.ss +++ b/collects/tests/mzscheme/embed-me5.ss @@ -1,3 +1,6 @@ (module embed-me5 mzscheme (require (lib "mred.ss" "mred")) - (printf "This is 5: ~s\n" button%)) + (with-output-to-file "stdout" + (lambda () (printf "This is 5: ~s\n" button%)) + 'append)) + diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 4da9fa5e4c..261fdc2071 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -23,10 +23,8 @@ (when (file-exists? exe) (delete-file exe))) -(define (try-exe exe expect) - (let ([out (open-output-bytes)] - [in (open-input-bytes #"")] - [plthome (getenv "PLTHOME")] +(define (try-exe exe expect mred?) + (let ([plthome (getenv "PLTHOME")] [collects (getenv "PLTCOLLECTS")]) ;; Try to hide usual collections: (when plthome @@ -34,17 +32,21 @@ (when collects (putenv "PLTCOLLECTS" (path->string (find-system-path 'temp-dir)))) ;; Execute: - (parameterize ([current-output-port out] - [current-input-port in]) + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (when (file-exists? "stdout") + (delete-file "stdout")) (system* exe)) (when plthome (putenv "PLTHOME" plthome)) (when collects - (putenv "PLTCOLLECTS" "")) - (test expect get-output-string out))) + (putenv "PLTCOLLECTS" collects)) + (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") + (lambda () (read-string 5000))))) (define (mz-tests mred?) (define dest (if mred? mr-dest mz-dest)) + (define (flags s) + (string-append "-" (if mred? "Z" "") "mvq" s)) (define (one-mz-test filename expect) ;; Try simple mode: one module, launched from cmd line: (prepare dest filename) @@ -53,8 +55,8 @@ `((#t (lib ,filename "tests" "mzscheme"))) null null - `("-mvqL" ,filename "tests/mzscheme")) - (try-exe dest expect) + `(,(flags "L") ,filename "tests/mzscheme")) + (try-exe dest expect mred?) ;; Try explicit prefix: (let ([w/prefix @@ -68,7 +70,7 @@ `("-mvqe" ,(format "(require ~a~a)" (or pfx "") (regexp-replace #rx"[.].*$" filename "")))) - (try-exe dest expect))]) + (try-exe dest expect mred?))]) (w/prefix #f) (w/prefix 'before:)) @@ -80,8 +82,8 @@ `((#t ,path)) null `(require (file ,(path->string path))) - `("-mvq"))) - (try-exe dest expect) + `(,(flags "")))) + (try-exe dest expect mred?) ;; Use `file' form: (prepare dest filename) @@ -91,8 +93,8 @@ `((#t (file ,(path->string path)))) null `(require (file ,(path->string path))) - `("-mvq"))) - (try-exe dest expect) + `(,(flags "")))) + (try-exe dest expect mred?) ;; Use relative path (prepare dest filename) @@ -102,8 +104,8 @@ `((#f ,filename)) null `(require ,(string->symbol (regexp-replace #rx"[.].*$" filename ""))) - `("-mvq"))) - (try-exe dest expect) + `(,(flags "")))) + (try-exe dest expect mred?) ;; Try multiple modules (prepare dest filename) @@ -115,8 +117,8 @@ `(begin (require (lib "embed-me3.ss" "tests" "mzscheme")) (require (lib ,filename "tests" "mzscheme"))) - `("-mvq")) - (try-exe dest (string-append "3 is here, too? #t\n" expect)) + `(,(flags ""))) + (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) ;; Try a literal file (prepare dest filename) @@ -124,12 +126,15 @@ dest mred? #f `((#t (lib ,filename "tests" "mzscheme"))) (list (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) - `(begin (display "... and more!\n")) - `("-mvqL" ,filename "tests/mzscheme")) + `(with-output-to-file "stdout" + (lambda () (display "... and more!\n")) + 'append) + `(,(flags "L") ,filename "tests/mzscheme")) (try-exe dest (string-append "This is the literal expression 4.\n" "... and more!\n" - expect))) + expect) + mred?)) (one-mz-test "embed-me1.ss" "This is 1\n") (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n") @@ -137,12 +142,17 @@ ;; Try unicode expr and cmdline: (prepare dest "unicode") (make-embedding-executable - dest #f #f + dest mred? #f null null - `(printf "\uA9, \u7238, and \U1D670\n") - `("-mvqe" "(display \"\u7237...\U1D671\n\")")) - (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n")) + `(begin + (define (out s) + (with-output-to-file "stdout" + (lambda () (printf s)) + 'append)) + (out "\uA9, \u7238, and \U1D670\n")) + `(,(flags "e") "(out \"\u7237...\U1D671\n\")")) + (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) (mz-tests #f) (mz-tests #t) @@ -154,6 +164,6 @@ null null `("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) -(try-exe mr-dest "This is 5: #\n") +(try-exe mr-dest "This is 5: #\n" #t) (report-errs) From b087b10700fe1d4eb8739699589fddefc942945f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2004 16:03:03 +0000 Subject: [PATCH 040/466] . original commit: 6df12c17304c3a139157e67a0067694aef5d587a --- collects/tests/mzscheme/embed.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 261fdc2071..943bcdb29e 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -67,9 +67,9 @@ `((,pfx (lib ,filename "tests" "mzscheme"))) null null - `("-mvqe" ,(format "(require ~a~a)" - (or pfx "") - (regexp-replace #rx"[.].*$" filename "")))) + `(,(flags "e") ,(format "(require ~a~a)" + (or pfx "") + (regexp-replace #rx"[.].*$" filename "")))) (try-exe dest expect mred?))]) (w/prefix #f) (w/prefix 'before:)) From 6cec0bd74d442d710344ce569b7ab6cafa72234e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 16 Oct 2004 16:26:12 +0000 Subject: [PATCH 041/466] . original commit: 7238f06a9482b75ca6714d59e1e58e3393baa5df --- collects/tests/mzscheme/embed.ss | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 943bcdb29e..2ffa11ba44 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -35,7 +35,11 @@ (parameterize ([current-directory (find-system-path 'temp-dir)]) (when (file-exists? "stdout") (delete-file "stdout")) - (system* exe)) + (system* (if (and mred? (eq? 'macosx (system-type))) + (let-values ([(base name dir?) (split-path exe)]) + (build-path exe "Contents" "MacOS" + (path-replace-suffix name #""))) + exe))) (when plthome (putenv "PLTHOME" plthome)) (when collects From 4ba4bc9a9ae22f33514c2ee90b1dcbd56dc0a243 Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Thu, 3 Feb 2005 14:24:22 +0000 Subject: [PATCH 042/466] Added support for planet files by internally reorganizing setup-unit: the cc structure once represented a collection to be compiled; now it represents a directory to be compiled, with different ways of constructing a cc applying to libraries and collection paths. original commit: 56358bed791e23498e841586da0bb0901bbe0c2f --- collects/setup/option-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index c8040aa556..2a6b1c78a4 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -18,6 +18,7 @@ pause-on-errors force-unpacks specific-collections + specific-planet-dirs archives current-target-directory-getter current-target-plt-directory-getter))) From fc4358a08804ad31a47d8449150fb1e0dea3b2b7 Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Thu, 3 Feb 2005 15:21:12 +0000 Subject: [PATCH 043/466] Added compile-directory-zos original commit: 7553204899c249d41707cd30644e26be343fae81 --- collects/compiler/sig.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 6256a711e7..b351979c1c 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -84,6 +84,9 @@ compile-collection-extension compile-collection-zos + compile-directory-extension + compile-directory-zos + current-compiler-dynamic-require-wrapper compile-notify-handler)) From 6a82852338d4760a9bbef98c643314bc7a9a7fb5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 Mar 2005 17:15:45 +0000 Subject: [PATCH 044/466] . original commit: 5ebf6026625d2a02f8d5c28d1dd62c3bbc467d37 --- collects/compiler/embed-sig.ss | 3 ++- collects/launcher/launcher-sig.ss | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss index 16c593fe79..d6fd69d078 100644 --- a/collects/compiler/embed-sig.ss +++ b/collects/compiler/embed-sig.ss @@ -7,4 +7,5 @@ (make-embedding-executable write-module-bundle embedding-executable-is-directory? - embedding-executable-put-file-extension+style+filters))) + embedding-executable-put-file-extension+style+filters + embedding-executable-add-suffix))) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index b126afe7c2..bd643a46bf 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -23,6 +23,9 @@ mred-launcher-is-directory? mzscheme-launcher-is-directory? + mred-launcher-add-suffix + mzscheme-launcher-add-suffix + mred-launcher-put-file-extension+style+filters mzscheme-launcher-put-file-extension+style+filters From b69a2ea5b87b9036b16d28057e0e02598b8d1629 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 6 Oct 2005 15:54:38 +0000 Subject: [PATCH 045/466] improved file dialogs for mac os x, changed create-executable interface, and fixed parsing of infix dots to require a delimitter after the second dot svn: r1000 original commit: 5c1a331d3b41190df3a549d2ddb09e4fa4df53a8 --- collects/launcher/launcher-sig.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index bd643a46bf..37aba83599 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -23,6 +23,9 @@ mred-launcher-is-directory? mzscheme-launcher-is-directory? + mred-launcher-is-actually-directory? + mzscheme-launcher-is-actually-directory? + mred-launcher-add-suffix mzscheme-launcher-add-suffix From bdd9fc9b2ffef8eed89d53fe75e0c133fc62cbd2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 19 Nov 2005 16:19:42 +0000 Subject: [PATCH 046/466] 3m and mzc svn: r1353 original commit: 58b6198fa580d56a5656b45cf90e2d1187867f5f --- collects/compiler/sig.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index b351979c1c..f21117d961 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -22,6 +22,9 @@ clean-intermediate-files ; #t => keep intermediate .c/.o files ; default = #f + + 3m ; #t => build for 3m + ; default = #f compile-subcollections ; #t => use 'compile-subcollections ; from infor for collection compiling From 2e9d47093590c518f1ca2aba953e16548d71d605 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Dec 2005 14:27:12 +0000 Subject: [PATCH 047/466] many repairs to Create Executable... svn: r1558 original commit: d9bad21ca2c85d09bd477921e469cad3c316f567 --- collects/compiler/embed-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss index d6fd69d078..fc628c7fb1 100644 --- a/collects/compiler/embed-sig.ss +++ b/collects/compiler/embed-sig.ss @@ -7,5 +7,6 @@ (make-embedding-executable write-module-bundle embedding-executable-is-directory? + embedding-executable-is-actually-directory? embedding-executable-put-file-extension+style+filters embedding-executable-add-suffix))) From 25540a9279ae4eceb4049c85b2549c70a45402c0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 23 Apr 2006 02:36:55 +0000 Subject: [PATCH 048/466] 301.13 (the beginning of the end for PLTHOME) svn: r2740 original commit: 1d77707ef13b309083a29fa85039c9b17f9e2871 --- collects/compiler/embed-sig.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss index fc628c7fb1..b177327dbd 100644 --- a/collects/compiler/embed-sig.ss +++ b/collects/compiler/embed-sig.ss @@ -4,7 +4,8 @@ (provide compiler:embed^) (define-signature compiler:embed^ - (make-embedding-executable + (create-embedding-executable + make-embedding-executable write-module-bundle embedding-executable-is-directory? embedding-executable-is-actually-directory? From cb4f6b5e6ee967cd697cdf662441661e7e1b8044 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 9 May 2006 16:58:37 +0000 Subject: [PATCH 049/466] add --multi mode for -o/-g svn: r2888 original commit: 2e944e3e2e6b1b42f487536435df5dc4b24ec3ab --- collects/compiler/sig.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index f21117d961..16729ae628 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -81,6 +81,7 @@ link-extension-parts glue-extension-parts + glue-extension-parts-to-c compile-zos @@ -106,4 +107,5 @@ ;; Low-level multi-file extension linker interface (define-signature compiler:linker^ (link-extension - glue-extension))) + glue-extension + glue-extension-source))) From 311bc577fc1fb4f9787bb80f0a4e9ea0870d6102 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Jun 2006 11:52:48 +0000 Subject: [PATCH 050/466] new Create Executable in DrScheme svn: r3178 original commit: 09d6dd95cfd48cb0418996699ce5849ddc5b315a --- collects/compiler/bundle-dist.ss | 93 ++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 collects/compiler/bundle-dist.ss diff --git a/collects/compiler/bundle-dist.ss b/collects/compiler/bundle-dist.ss new file mode 100644 index 0000000000..7976dfb7df --- /dev/null +++ b/collects/compiler/bundle-dist.ss @@ -0,0 +1,93 @@ + +(module bundle-dist mzscheme + (require (lib "etc.ss") + (lib "file.ss") + (lib "process.ss") + (lib "zip.ss") + (lib "tar.ss")) + + (provide bundle-put-file-extension+style+filters + bundle-directory) + + (define (bundle-file-suffix) + (case (system-type) + [(macosx) "dmg"] + [(windows) "zip"] + [(unix) "tgz"])) + + (define (bundle-put-file-extension+style+filters) + (values (bundle-file-suffix) + null + (case (system-type) + [(windows) '(("Zip file" "*.zip"))] + [(macosx) '(("Disk image" "*.dmg"))] + [(unix) '(("Gzipped tar file" "*.tgz"))]))) + + (define (add-suffix name suffix) + (if (filename-extension name) + name + (path-replace-suffix name + (string->bytes/utf-8 (string-append "." suffix))))) + + (define (with-prepared-directory dir for-exe? k) + ;; If `dir' contains multiple files, create a new + ;; directory that contains a copy of `dir' + (if (and for-exe? + (= 1 (length (directory-list dir)))) + (k dir) + (let ([temp-dir (make-temporary-file "bundle-tmp-~a" 'directory)]) + (dynamic-wind + void + (lambda () + (let ([dest + (let-values ([(base name dir?) (split-path dir)]) + (build-path temp-dir name))]) + (make-directory dest) + (let loop ([src dir][dest dest]) + (for-each (lambda (f) + (let ([src (build-path src f)] + [dest (build-path dest f)]) + (cond + [(directory-exists? src) + (make-directory dest) + (loop src dest)] + [(file-exists? src) + (copy-file src dest) + (file-or-directory-modify-seconds + dest + (file-or-directory-modify-seconds src))]))) + (directory-list src)))) + (k temp-dir)) + (lambda () (delete-directory/files temp-dir)))))) + + (define bundle-directory + (opt-lambda (target dir [for-exe? #f]) + (let ([target (add-suffix target (bundle-file-suffix))]) + (case (system-type) + [(macosx) + (with-prepared-directory + dir for-exe? + (lambda (dir) + (let* ([cout (open-output-bytes)] + [cerr (open-output-bytes)] + [cin (open-input-bytes #"")] + [p (process*/ports + cout cin cerr + "/usr/bin/hdiutil" + "create" "-format" "UDZO" + "-imagekey" "zlib-level=9" + "-mode" "555" + "-volname" (path->string + (path-replace-suffix (file-name-from-path target) #"")) + "-srcfolder" (path->string (path->complete-path dir)) + (path->string (path->complete-path target)))]) + ((list-ref p 4) 'wait) + (unless (eq? ((list-ref p 4) 'status) 'done-ok) + (error 'bundle-directory + "error bundling: ~a" + (regexp-replace #rx"[\r\n]*$" (get-output-string cerr) ""))))))] + [(windows unix) + (let-values ([(base name dir?) (split-path dir)]) + (parameterize ([current-directory base]) + ((if (eq? 'unix (system-type)) tar-gzip zip) target name)))] + [else (error 'bundle-directory "don't know how")]))))) From 0f76b637dbbf8d357bd1856b388fed66ae5aa0fd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 18 Jun 2006 01:58:29 +0000 Subject: [PATCH 051/466] improved create-executable test suite, fix for Mac OS X MrEd executable with given collection path svn: r3391 original commit: cb7c8232065b7ca82d05cea0aea0bdca2ed91e09 --- collects/tests/mzscheme/embed.ss | 65 ++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 2ffa11ba44..2a9685f9f7 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -170,4 +170,69 @@ `("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) (try-exe mr-dest "This is 5: #\n" #t) +;; Try the mzc interface: +(require (lib "dirs.ss" "setup") + (lib "file.ss")) +(define mzc (build-path (find-console-bin-dir) "mzc")) + +(define (mzc-tests mred?) + (parameterize ([current-directory (find-system-path 'temp-dir)]) + + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me1.ss"))) + (try-exe (mk-dest mred?) "This is 1\n" mred?) + + ;; Check that etc.ss isn't found if it's not included: + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) + + ;; And it is found if it is included: + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "++lib" "etc.ss" "mzlib" + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + + ;; Or, it's found if we set the collection path: + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "--collects-path" + (path->string (find-collects-dir)) + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + + ;; Try --collects-dest mode + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "++lib" "etc.ss" "mzlib" + "--collects-dest" "cts" + "--collects-path" "cts" + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + (delete-directory/files "cts") + (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) + + (void))) + +(mzc-tests #t) +(mzc-tests #f) + +;; One MrEd-specific test with mzc: +(parameterize ([current-directory (find-system-path 'temp-dir)]) + (system* mzc + "--gui-exe" + (path->string (mk-dest #t)) + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss"))) + (try-exe (mk-dest #t) "This is 5: #\n" #t)) + + + (report-errs) From 7af0ccb668dd76fd9f6c305c02967f9560e013ef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 18 Jun 2006 02:00:13 +0000 Subject: [PATCH 052/466] new support file for make-executable tests svn: r3392 original commit: 8d3d7b10d39cf97fc11aaf848b81e60ac5543631 --- collects/tests/mzscheme/embed-me6.ss | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 collects/tests/mzscheme/embed-me6.ss diff --git a/collects/tests/mzscheme/embed-me6.ss b/collects/tests/mzscheme/embed-me6.ss new file mode 100644 index 0000000000..74ec1f8354 --- /dev/null +++ b/collects/tests/mzscheme/embed-me6.ss @@ -0,0 +1,8 @@ +(module embed-me6 mzscheme + (with-output-to-file "stdout" + (lambda () + (printf "This is 6\n") + (with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))]) + (printf "~a\n" (dynamic-require '(lib "etc.ss") 'true)))) + 'append)) + From f970162284343f43605818019fafea9d31af53ef Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 7 Jul 2006 23:46:35 +0000 Subject: [PATCH 053/466] Better output: using quiet.ss will show nothing except for section headers and errors (if any). Also, using quiet.ss will exit with an error code if there were errors. svn: r3655 original commit: bbf54efde9725215d56bb0d6eafaf23970f6820f --- collects/tests/mzscheme/embed.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 2a9685f9f7..ac38462f3d 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -1,7 +1,7 @@ (load-relative "loadtest.ss") -(SECTION 'embed) +(Section 'embed) (require (lib "embed.ss" "compiler") (lib "process.ss")) From 44098e109365af387fddfca625a54d5ca022e9a9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 5 Dec 2006 20:31:14 +0000 Subject: [PATCH 054/466] merged units branch svn: r5033 original commit: 3459c3a58f1cdc52fbc916acf306b29408468912 --- collects/compiler/embed-sig.ss | 2 +- collects/compiler/sig.ss | 2 +- collects/launcher/launcher-sig.ss | 11 +++-------- collects/setup/option-sig.ss | 2 +- 4 files changed, 6 insertions(+), 11 deletions(-) diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss index b177327dbd..dede40321b 100644 --- a/collects/compiler/embed-sig.ss +++ b/collects/compiler/embed-sig.ss @@ -1,6 +1,6 @@ (module embed-sig mzscheme - (require (lib "unitsig.ss")) + (require (lib "unit.ss")) (provide compiler:embed^) (define-signature compiler:embed^ diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 16729ae628..584e5821a9 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -1,7 +1,7 @@ (module sig mzscheme - (require (lib "unitsig.ss")) + (require (lib "unit.ss")) (provide compiler:option^ compiler^ diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index 37aba83599..ebcdce03a8 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -1,11 +1,6 @@ -(module launcher-sig mzscheme - (require (lib "unitsig.ss")) - - (provide launcher^) - - (define-signature launcher^ - (make-mred-launcher +(module launcher-sig (lib "a-signature.ss") + make-mred-launcher make-mzscheme-launcher make-mred-program-launcher @@ -35,4 +30,4 @@ build-aux-from-path current-launcher-variant available-mred-variants - available-mzscheme-variants))) + available-mzscheme-variants) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 2a6b1c78a4..517d218662 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -1,6 +1,6 @@ (module option-sig mzscheme - (require (lib "unitsig.ss")) + (require (lib "unit.ss")) (provide setup-option^) From 6b33e9615e877185724f751117a41bd20795cb1e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 Dec 2006 01:26:58 +0000 Subject: [PATCH 055/466] unit clean-up svn: r5160 original commit: 7b13755dadb4945ff467a1d6b1a067e76a53767c --- collects/compiler/sig.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 584e5821a9..1cab9f0cd0 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -51,7 +51,7 @@ ; e.g.: ((lambda () 0) 1 2 3) vehicles ; Controls how closures are compiled: - ; 'vehicles:automatic, + ; 'vehicles:automatic, ; 'vehicles:functions, ; 'vechicles:units, or ; 'vehicles:monolithic. From db3fe62e393f78d82ba813cc73ed031a592ee913 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Apr 2007 01:16:15 +0000 Subject: [PATCH 056/466] 369.10 svn: r6003 original commit: a45251d27211d633dc1834a92bc44bddeb983316 --- collects/tests/mzscheme/embed-me10.ss | 9 ++ collects/tests/mzscheme/embed-me8.c | 31 +++++ collects/tests/mzscheme/embed-me9.ss | 6 + collects/tests/mzscheme/embed.ss | 156 ++++++++++++++++++++++---- 4 files changed, 180 insertions(+), 22 deletions(-) create mode 100644 collects/tests/mzscheme/embed-me10.ss create mode 100644 collects/tests/mzscheme/embed-me8.c create mode 100644 collects/tests/mzscheme/embed-me9.ss diff --git a/collects/tests/mzscheme/embed-me10.ss b/collects/tests/mzscheme/embed-me10.ss new file mode 100644 index 0000000000..807eb8705d --- /dev/null +++ b/collects/tests/mzscheme/embed-me10.ss @@ -0,0 +1,9 @@ +(module embed-me10 mzscheme + (require (lib "mzssl.ss" "openssl")) + + (with-output-to-file "stdout" + (lambda () + (printf "~a\n" ssl-available?)) + 'append)) + + diff --git a/collects/tests/mzscheme/embed-me8.c b/collects/tests/mzscheme/embed-me8.c new file mode 100644 index 0000000000..c4fda30513 --- /dev/null +++ b/collects/tests/mzscheme/embed-me8.c @@ -0,0 +1,31 @@ +#include "escheme.h" + +Scheme_Object *ex(int argc, Scheme_Object **argv) +{ + return scheme_make_utf8_string("Hello, world!"); +} + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + Scheme_Env *menv; + + menv = scheme_primitive_module(scheme_intern_symbol("embed-me8"), + env); + + scheme_add_global("ex", scheme_make_prim_w_arity(ex, "ex", 0, 0), menv); + + scheme_finish_primitive_module(menv); + + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + /* First load is same as every load: */ + return scheme_reload(env); +} + +Scheme_Object *scheme_module_name() +{ + return scheme_intern_symbol("embed-me8"); +} diff --git a/collects/tests/mzscheme/embed-me9.ss b/collects/tests/mzscheme/embed-me9.ss new file mode 100644 index 0000000000..877eed97de --- /dev/null +++ b/collects/tests/mzscheme/embed-me9.ss @@ -0,0 +1,6 @@ +(module embed-me9 mzscheme + (require "embed-me8.ss") + (with-output-to-file "stdout" + (lambda () + (printf "~a\n" (ex))) + 'append)) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index ac38462f3d..9ab5ff962b 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -4,33 +4,52 @@ (Section 'embed) (require (lib "embed.ss" "compiler") - (lib "process.ss")) + (lib "file.ss") + (lib "process.ss") + (lib "distribute.ss" "compiler")) + +(define (mk-dest-bin mred?) + (case (system-type) + [(windows) "e.exe"] + [(unix) "e"] + [(macosx) (if mred? + "e.app" + "e")])) (define (mk-dest mred?) (build-path (find-system-path 'temp-dir) - (case (system-type) - [(windows) "e.exe"] - [(unix) "e"] - [(macosx) (if mred? - "e.app" - "e")]))) + (mk-dest-bin mred?))) (define mz-dest (mk-dest #f)) (define mr-dest (mk-dest #t)) +(define dist-dir (build-path (find-system-path 'temp-dir) + "e-dist")) +(define dist-mz-exe (build-path + (case (system-type) + [(windows) 'same] + [else "bin"]) + (mk-dest-bin #f))) +(define dist-mred-exe (build-path + (case (system-type) + [(windows macosx) 'same] + [else "bin"]) + (mk-dest-bin #t))) + (define (prepare exe src) (printf "Making ~a with ~a...~n" exe src) (when (file-exists? exe) (delete-file exe))) -(define (try-exe exe expect mred?) +(define (try-one-exe exe expect mred?) + (printf "Running ~a\n" exe) (let ([plthome (getenv "PLTHOME")] [collects (getenv "PLTCOLLECTS")]) ;; Try to hide usual collections: (when plthome - (putenv "PLTHOME" (path->string (find-system-path 'temp-dir)))) + (putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) (when collects - (putenv "PLTCOLLECTS" (path->string (find-system-path 'temp-dir)))) + (putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) ;; Execute: (parameterize ([current-directory (find-system-path 'temp-dir)]) (when (file-exists? "stdout") @@ -47,6 +66,24 @@ (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (read-string 5000))))) +(define try-exe + (case-lambda + [(exe expect mred?) + (try-exe exe expect mred? void)] + [(exe expect mred? dist-hook . collects) + (try-one-exe exe expect mred?) + ;; Build a distirbution directory, and try that, too: + (when (directory-exists? dist-dir) + (delete-directory/files dist-dir)) + (assemble-distribution dist-dir (list exe) #:copy-collects collects) + (dist-hook) + (try-one-exe (build-path dist-dir + (if mred? + dist-mred-exe + dist-mz-exe)) + expect mred?) + (delete-directory/files dist-dir)])) + (define (mz-tests mred?) (define dest (if mred? mr-dest mz-dest)) (define (flags s) @@ -161,19 +198,22 @@ (mz-tests #f) (mz-tests #t) -(prepare mr-dest "embed-me5.ss") -(make-embedding-executable - mr-dest #t #f - `((#t (lib "embed-me5.ss" "tests" "mzscheme"))) - null - null - `("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) -(try-exe mr-dest "This is 5: #\n" #t) +(begin + (prepare mr-dest "embed-me5.ss") + (make-embedding-executable + mr-dest #t #f + `((#t (lib "embed-me5.ss" "tests" "mzscheme"))) + null + null + `("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) + (try-exe mr-dest "This is 5: #\n" #t)) ;; Try the mzc interface: (require (lib "dirs.ss" "setup") (lib "file.ss")) -(define mzc (build-path (find-console-bin-dir) "mzc")) +(define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) + "mzc.exe" + "mzc"))) (define (mzc-tests mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) @@ -206,7 +246,8 @@ "--collects-path" (path->string (find-collects-dir)) (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) - (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + ;; Don't try a distribution for this one: + (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Try --collects-dest mode (system* mzc @@ -216,7 +257,7 @@ "--collects-dest" "cts" "--collects-path" "cts" (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) - (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) @@ -225,7 +266,65 @@ (mzc-tests #t) (mzc-tests #f) -;; One MrEd-specific test with mzc: +(require (lib "file.ss" "dynext")) +(define (extension-test mred?) + (parameterize ([current-directory (find-system-path 'temp-dir)]) + + (define obj-file + (build-path (find-system-path 'temp-dir) (append-object-suffix "embed-me8"))) + + (define ext-base-dir + (build-path (find-system-path 'temp-dir) + "compiled")) + + (define ext-dir + (build-path ext-base-dir + "native" + (system-library-subpath))) + + (define ext-file + (build-path ext-dir (append-extension-suffix "embed-me8"))) + + (define ss-file + (build-path (find-system-path 'temp-dir) "embed-me9.ss")) + + (make-directory* ext-dir) + + (system* mzc + "--cc" + "-d" (path->string (path-only obj-file)) + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me8.c"))) + (system* mzc + "--ld" + (path->string ext-file) + (path->string obj-file)) + + (when (file-exists? ss-file) + (delete-file ss-file)) + (copy-file (build-path (collection-path "tests" "mzscheme") "embed-me9.ss") + ss-file) + + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string ss-file)) + + (delete-file ss-file) + + (try-exe (mk-dest mred?) "Hello, world!\n" mred? (lambda () + (delete-directory/files ext-base-dir))) + + ;; openssl, which needs extra binaries under Windows + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me10.ss"))) + (try-exe (mk-dest mred?) "#t\n" mred?))) + +(extension-test #f) +(extension-test #t) + +;; A MrEd-specific test with mzc: (parameterize ([current-directory (find-system-path 'temp-dir)]) (system* mzc "--gui-exe" @@ -233,6 +332,19 @@ (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss"))) (try-exe (mk-dest #t) "This is 5: #\n" #t)) +;; Another MrEd-specific: try embedding plot, which has extra DLLs and font files: +(parameterize ([current-directory (find-system-path 'temp-dir)]) + (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) + (system* (build-path (find-console-bin-dir) "mred") + "-qu" + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")) + (path->string direct)) + + (system* mzc + "--gui-exe" + (path->string (mk-dest #t)) + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss"))) + (try-exe (mk-dest #t) "plotted\n" #t)) (report-errs) From 948669c76e9225dbe2b0ad35ce9549729986e1bc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Apr 2007 21:33:56 +0000 Subject: [PATCH 057/466] doc correction, and expand paths before passing them on the command line svn: r6017 original commit: b4ad09c116d6332df1ca93cf6312ffa66f8fbbd8 --- collects/compiler/bundle-dist.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/bundle-dist.ss b/collects/compiler/bundle-dist.ss index 7976dfb7df..f908b655d5 100644 --- a/collects/compiler/bundle-dist.ss +++ b/collects/compiler/bundle-dist.ss @@ -79,8 +79,8 @@ "-mode" "555" "-volname" (path->string (path-replace-suffix (file-name-from-path target) #"")) - "-srcfolder" (path->string (path->complete-path dir)) - (path->string (path->complete-path target)))]) + "-srcfolder" (path->string (expand-path (path->complete-path dir))) + (path->string (expand-path (path->complete-path target))))]) ((list-ref p 4) 'wait) (unless (eq? ((list-ref p 4) 'status) 'done-ok) (error 'bundle-directory From a148d4e5478fecb1282711385276953f19dde7e3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Apr 2007 00:43:51 +0000 Subject: [PATCH 058/466] test and fix hook for create-embedding-executable svn: r6036 original commit: 6afb79188df93c871f81f2c0fd746f23c1751eac --- collects/tests/mzscheme/embed-me11-rd.ss | 15 ++++++++++++ collects/tests/mzscheme/embed.ss | 29 ++++++++++++++++++++++++ 2 files changed, 44 insertions(+) create mode 100644 collects/tests/mzscheme/embed-me11-rd.ss diff --git a/collects/tests/mzscheme/embed-me11-rd.ss b/collects/tests/mzscheme/embed-me11-rd.ss new file mode 100644 index 0000000000..682396a20b --- /dev/null +++ b/collects/tests/mzscheme/embed-me11-rd.ss @@ -0,0 +1,15 @@ +(module embed-me11-rd mzscheme + (provide (rename *read-syntax read-syntax) + (rename *read read)) + + (define (*read port) + `(module embed-me11 mzscheme + (with-output-to-file "stdout" + (lambda () + (printf ,(read port) + ;; Use `getenv' at read time!!! + ,(getenv "ELEVEN"))) + 'append))) + + (define (*read-syntax src port) + (*read port))) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 9ab5ff962b..0e7b471278 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -347,4 +347,33 @@ (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss"))) (try-exe (mk-dest #t) "plotted\n" #t)) +;; Try including source that needs a reader extension + +(define (try-reader-test mred?) + (define dest (mk-dest mred?)) + (define filename "embed-me11.ss") + (define (flags s) + (string-append "-" (if mred? "Z" "") "mvq" s)) + + (create-embedding-executable + dest + #:modules `((#t (lib ,filename "tests" "mzscheme"))) + #:cmdline `(,(flags "L") ,filename "tests/mzscheme") + #:src-filter (lambda (f) + (let-values ([(base name dir?) (split-path f)]) + (equal? name (string->path filename)))) + #:get-extra-imports (lambda (f code) + (let-values ([(base name dir?) (split-path f)]) + (if (equal? name (string->path filename)) + '((lib "embed-me11-rd.ss" "tests" "mzscheme")) + null))) + #:mred? mred?) + + (putenv "ELEVEN" "eleven") + (try-exe dest "It goes to eleven!\n" mred?) + (putenv "ELEVEN" "done")) + +(try-reader-test #f) +(try-reader-test #t) + (report-errs) From e4ad919f651c2a87a2215e0561fc46b39dc95b0b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 29 May 2007 11:45:44 +0000 Subject: [PATCH 059/466] add missing path->complete-path for unix/windows bundle-directory svn: r6371 original commit: 73a913f63f8dea843ed06bdbec1ba2dfe1073005 --- collects/compiler/bundle-dist.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/bundle-dist.ss b/collects/compiler/bundle-dist.ss index f908b655d5..b0e91479c6 100644 --- a/collects/compiler/bundle-dist.ss +++ b/collects/compiler/bundle-dist.ss @@ -87,7 +87,7 @@ "error bundling: ~a" (regexp-replace #rx"[\r\n]*$" (get-output-string cerr) ""))))))] [(windows unix) - (let-values ([(base name dir?) (split-path dir)]) + (let-values ([(base name dir?) (split-path (path->complete-path dir))]) (parameterize ([current-directory base]) ((if (eq? 'unix (system-type)) tar-gzip zip) target name)))] [else (error 'bundle-directory "don't know how")]))))) From 34fe3cea9150d17a36c682d59ce53bad6abfb1c8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 2 Sep 2007 17:39:32 +0000 Subject: [PATCH 060/466] 371.2 svn: r7263 original commit: e4cbc4e6a938fd5bd90aab305ca39d61e7eae151 --- collects/setup/option-sig.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 517d218662..cd577e538e 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -14,9 +14,12 @@ make-so make-info-domain make-launchers + make-docs call-install + call-post-install pause-on-errors force-unpacks + doc-pdf-dest specific-collections specific-planet-dirs archives From 553733c465b7d1ecb16e909fe85f58daf9fb4f79 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 13 Nov 2007 12:40:00 +0000 Subject: [PATCH 061/466] v3.99.0.2 svn: r7706 original commit: 39cedb62edf9258b051a22a29a90be9c6841956f --- collects/launcher/launcher-sig.ss | 47 ++++++++--------- collects/tests/mzscheme/embed.ss | 86 +++++++++++++++++++------------ 2 files changed, 76 insertions(+), 57 deletions(-) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index ebcdce03a8..1b5d41289b 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -1,33 +1,34 @@ -(module launcher-sig (lib "a-signature.ss") - make-mred-launcher - make-mzscheme-launcher +#lang scheme/signature - make-mred-program-launcher - make-mzscheme-program-launcher +make-mred-launcher +make-mzscheme-launcher - mred-program-launcher-path - mzscheme-program-launcher-path +make-mred-program-launcher +make-mzscheme-program-launcher - install-mred-program-launcher - install-mzscheme-program-launcher +mred-program-launcher-path +mzscheme-program-launcher-path - mred-launcher-up-to-date? - mzscheme-launcher-up-to-date? +install-mred-program-launcher +install-mzscheme-program-launcher - mred-launcher-is-directory? - mzscheme-launcher-is-directory? +mred-launcher-up-to-date? +mzscheme-launcher-up-to-date? - mred-launcher-is-actually-directory? - mzscheme-launcher-is-actually-directory? +mred-launcher-is-directory? +mzscheme-launcher-is-directory? - mred-launcher-add-suffix - mzscheme-launcher-add-suffix +mred-launcher-is-actually-directory? +mzscheme-launcher-is-actually-directory? - mred-launcher-put-file-extension+style+filters - mzscheme-launcher-put-file-extension+style+filters +mred-launcher-add-suffix +mzscheme-launcher-add-suffix - build-aux-from-path - current-launcher-variant - available-mred-variants - available-mzscheme-variants) +mred-launcher-put-file-extension+style+filters +mzscheme-launcher-put-file-extension+style+filters + +build-aux-from-path +current-launcher-variant +available-mred-variants +available-mzscheme-variants diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 0e7b471278..191d4baffd 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -54,11 +54,12 @@ (parameterize ([current-directory (find-system-path 'temp-dir)]) (when (file-exists? "stdout") (delete-file "stdout")) - (system* (if (and mred? (eq? 'macosx (system-type))) - (let-values ([(base name dir?) (split-path exe)]) - (build-path exe "Contents" "MacOS" - (path-replace-suffix name #""))) - exe))) + (test #t + system* (if (and mred? (eq? 'macosx (system-type))) + (let-values ([(base name dir?) (split-path exe)]) + (build-path exe "Contents" "MacOS" + (path-replace-suffix name #""))) + exe))) (when plthome (putenv "PLTHOME" plthome)) (when collects @@ -73,6 +74,7 @@ [(exe expect mred? dist-hook . collects) (try-one-exe exe expect mred?) ;; Build a distirbution directory, and try that, too: + (printf " ... from distribution ...\n") (when (directory-exists? dist-dir) (delete-directory/files dist-dir)) (assemble-distribution dist-dir (list exe) #:copy-collects collects) @@ -87,7 +89,7 @@ (define (mz-tests mred?) (define dest (if mred? mr-dest mz-dest)) (define (flags s) - (string-append "-" (if mred? "Z" "") "mvq" s)) + (string-append "-" s)) (define (one-mz-test filename expect) ;; Try simple mode: one module, launched from cmd line: (prepare dest filename) @@ -96,59 +98,66 @@ `((#t (lib ,filename "tests" "mzscheme"))) null null - `(,(flags "L") ,filename "tests/mzscheme")) + `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) (try-exe dest expect mred?) ;; Try explicit prefix: + (printf ">>>explicit prefix\n") (let ([w/prefix (lambda (pfx) (prepare dest filename) (make-embedding-executable dest mred? #f - `((,pfx (lib ,filename "tests" "mzscheme"))) + `((,pfx (lib ,filename "tests" "mzscheme")) + (#t (lib "scheme/init"))) null null - `(,(flags "e") ,(format "(require ~a~a)" - (or pfx "") - (regexp-replace #rx"[.].*$" filename "")))) + `(,(flags "ne") + ,(format "(#%require '~a~a)" + (or pfx "") + (regexp-replace #rx"[.].*$" filename "")))) (try-exe dest expect mred?))]) (w/prefix #f) (w/prefix 'before:)) ;; Try full path, and use literal S-exp to start + (printf ">>>literal sexp\n") (prepare dest filename) (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) (make-embedding-executable dest mred? #f `((#t ,path)) null - `(require (file ,(path->string path))) + `(#%require (file ,(path->string path))) `(,(flags "")))) (try-exe dest expect mred?) ;; Use `file' form: + (printf ">>>file\n") (prepare dest filename) (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) (make-embedding-executable dest mred? #f `((#t (file ,(path->string path)))) null - `(require (file ,(path->string path))) + `(#%require (file ,(path->string path))) `(,(flags "")))) (try-exe dest expect mred?) ;; Use relative path + (printf ">>>relative path\n") (prepare dest filename) (parameterize ([current-directory (collection-path "tests" "mzscheme")]) (make-embedding-executable dest mred? #f `((#f ,filename)) null - `(require ,(string->symbol (regexp-replace #rx"[.].*$" filename ""))) + `(#%require ',(string->symbol (regexp-replace #rx"[.].*$" filename ""))) `(,(flags "")))) (try-exe dest expect mred?) ;; Try multiple modules + (printf ">>>multiple\n") (prepare dest filename) (make-embedding-executable dest mred? #f @@ -156,12 +165,13 @@ (#t (lib "embed-me3.ss" "tests" "mzscheme"))) null `(begin - (require (lib "embed-me3.ss" "tests" "mzscheme")) - (require (lib ,filename "tests" "mzscheme"))) + (#%require (lib "embed-me3.ss" "tests" "mzscheme")) + (#%require (lib ,filename "tests" "mzscheme"))) `(,(flags ""))) (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) ;; Try a literal file + (printf ">>>literal\n") (prepare dest filename) (make-embedding-executable dest mred? #f @@ -170,7 +180,7 @@ `(with-output-to-file "stdout" (lambda () (display "... and more!\n")) 'append) - `(,(flags "L") ,filename "tests/mzscheme")) + `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) (try-exe dest (string-append "This is the literal expression 4.\n" "... and more!\n" @@ -184,15 +194,16 @@ (prepare dest "unicode") (make-embedding-executable dest mred? #f - null + '((#t scheme/base)) null `(begin + (#%require scheme/base) (define (out s) (with-output-to-file "stdout" (lambda () (printf s)) - 'append)) + #:exists 'append)) (out "\uA9, \u7238, and \U1D670\n")) - `(,(flags "e") "(out \"\u7237...\U1D671\n\")")) + `(,(flags "ne") "(out \"\u7237...\U1D671\n\")")) (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) (mz-tests #f) @@ -205,8 +216,8 @@ `((#t (lib "embed-me5.ss" "tests" "mzscheme"))) null null - `("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) - (try-exe mr-dest "This is 5: #\n" #t)) + `("-l" "tests/mzscheme/embed-me5.ss")) + (try-exe mr-dest "This is 5: #\n" #t)) ;; Try the mzc interface: (require (lib "dirs.ss" "setup") @@ -225,6 +236,7 @@ (try-exe (mk-dest mred?) "This is 1\n" mred?) ;; Check that etc.ss isn't found if it's not included: + (printf ">>not included\n") (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) @@ -232,14 +244,16 @@ (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) ;; And it is found if it is included: + (printf ">>included\n") (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - "++lib" "etc.ss" "mzlib" + "++lib" "mzlib/etc.ss" (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Or, it's found if we set the collection path: + (printf ">>set coll path\n") (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) @@ -250,21 +264,24 @@ (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Try --collects-dest mode + (printf ">>--collects-dest\n") (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - "++lib" "etc.ss" "mzlib" + "++lib" "mzlib/etc.ss" "--collects-dest" "cts" "--collects-path" "cts" (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") - (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) + (test #f system* (mk-dest mred?)) (void))) -(mzc-tests #t) +#| REMOVEME (mzc-tests #f) +(mzc-tests #t) +|# (require (lib "file.ss" "dynext")) (define (extension-test mred?) @@ -283,7 +300,7 @@ (system-library-subpath))) (define ext-file - (build-path ext-dir (append-extension-suffix "embed-me8"))) + (build-path ext-dir (append-extension-suffix "embed-me8_ss"))) (define ss-file (build-path (find-system-path 'temp-dir) "embed-me9.ss")) @@ -330,16 +347,17 @@ "--gui-exe" (path->string (mk-dest #t)) (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss"))) - (try-exe (mk-dest #t) "This is 5: #\n" #t)) + (try-exe (mk-dest #t) "This is 5: #\n" #t)) ;; Another MrEd-specific: try embedding plot, which has extra DLLs and font files: (parameterize ([current-directory (find-system-path 'temp-dir)]) (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) - (system* (build-path (find-console-bin-dir) "mred") - "-qu" - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")) - (path->string direct)) + (test #t + system* (build-path (find-console-bin-dir) "mred") + "-qu" + (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")) + (path->string direct)) (system* mzc "--gui-exe" @@ -353,12 +371,12 @@ (define dest (mk-dest mred?)) (define filename "embed-me11.ss") (define (flags s) - (string-append "-" (if mred? "Z" "") "mvq" s)) + (string-append "-" s)) (create-embedding-executable dest #:modules `((#t (lib ,filename "tests" "mzscheme"))) - #:cmdline `(,(flags "L") ,filename "tests/mzscheme") + #:cmdline `(,(flags "l") ,(string-append "tests/mzscheme/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) (equal? name (string->path filename)))) From 2d53c7cfb8925fa11b2cb10d737215b5478bf6f7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 11 Dec 2007 13:19:23 +0000 Subject: [PATCH 062/466] add --no-planet option to setup-plt svn: r7957 original commit: 487a71bf0d638f04602690bacef7e1762a447f32 --- collects/setup/option-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index cd577e538e..89e69d5124 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -15,6 +15,7 @@ make-info-domain make-launchers make-docs + make-planet call-install call-post-install pause-on-errors From 7678dce81b7c80e3118c340698a9370ab8cf3ffa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 27 Jan 2008 14:20:42 +0000 Subject: [PATCH 063/466] clean out _loader compilation support; merge compiler library docs into mzc manual; improve mzscheme cmdline handling so that configuration options do not cancel defaults like -i and -u svn: r8432 original commit: e35c94f91dface469a5c5689cd8f49b5d0d0a62e --- collects/compiler/sig.ss | 25 ++----------------------- collects/setup/option-sig.ss | 1 - 2 files changed, 2 insertions(+), 24 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 1cab9f0cd0..b8f638779f 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -5,8 +5,7 @@ (provide compiler:option^ compiler^ - compiler:inner^ - compiler:linker^) + compiler:inner^) ;; Compiler options (define-signature compiler:option^ @@ -75,20 +74,9 @@ compile-extensions-to-c compile-c-extensions - compile-extension-parts - compile-extension-parts-to-c - compile-c-extension-parts - - link-extension-parts - glue-extension-parts - glue-extension-parts-to-c - compile-zos - compile-collection-extension compile-collection-zos - - compile-directory-extension compile-directory-zos current-compiler-dynamic-require-wrapper @@ -99,13 +87,4 @@ (compile-extension compile-extension-to-c compile-c-extension - compile-extension-part - compile-extension-part-to-c - compile-c-extension-part - eval-compile-prefix)) - - ;; Low-level multi-file extension linker interface - (define-signature compiler:linker^ - (link-extension - glue-extension - glue-extension-source))) + eval-compile-prefix))) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 89e69d5124..12a1a7a12f 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -11,7 +11,6 @@ clean compile-mode make-zo - make-so make-info-domain make-launchers make-docs From b3de60d67483ccec74c3d4214f0535f85f047a9c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 8 Feb 2008 19:54:42 +0000 Subject: [PATCH 064/466] add -U to avoid compiling user-specific collects svn: r8590 original commit: 6b48a31ffbb4daca2a4e0ea2d9b161aec0674db2 --- collects/setup/option-sig.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 12a1a7a12f..1285a76453 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -14,6 +14,7 @@ make-info-domain make-launchers make-docs + make-user make-planet call-install call-post-install From aab2ad2f303be068256cb2f49f3cfad51bcfda27 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 23 Feb 2008 09:42:03 +0000 Subject: [PATCH 065/466] use new require specs in many places svn: r8774 original commit: b1a08edd5a8c0db0bae4a9e052d9a93d1faabb4f --- collects/compiler/bundle-dist.ss | 10 +++++----- collects/compiler/embed-sig.ss | 2 +- collects/compiler/sig.ss | 2 +- collects/setup/option-sig.ss | 2 +- collects/tests/mzscheme/embed-me2.ss | 2 +- collects/tests/mzscheme/embed-me3.ss | 2 +- collects/tests/mzscheme/embed-me5.ss | 2 +- collects/tests/mzscheme/embed.ss | 14 +++++++------- 8 files changed, 18 insertions(+), 18 deletions(-) diff --git a/collects/compiler/bundle-dist.ss b/collects/compiler/bundle-dist.ss index b0e91479c6..02a671be4f 100644 --- a/collects/compiler/bundle-dist.ss +++ b/collects/compiler/bundle-dist.ss @@ -1,10 +1,10 @@ (module bundle-dist mzscheme - (require (lib "etc.ss") - (lib "file.ss") - (lib "process.ss") - (lib "zip.ss") - (lib "tar.ss")) + (require mzlib/etc + mzlib/file + mzlib/process + mzlib/zip + mzlib/tar) (provide bundle-put-file-extension+style+filters bundle-directory) diff --git a/collects/compiler/embed-sig.ss b/collects/compiler/embed-sig.ss index dede40321b..a5e949c9a8 100644 --- a/collects/compiler/embed-sig.ss +++ b/collects/compiler/embed-sig.ss @@ -1,6 +1,6 @@ (module embed-sig mzscheme - (require (lib "unit.ss")) + (require mzlib/unit) (provide compiler:embed^) (define-signature compiler:embed^ diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index b8f638779f..b9577b6fa7 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -1,7 +1,7 @@ (module sig mzscheme - (require (lib "unit.ss")) + (require mzlib/unit) (provide compiler:option^ compiler^ diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 1285a76453..0bbdfe9b19 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -1,6 +1,6 @@ (module option-sig mzscheme - (require (lib "unit.ss")) + (require mzlib/unit) (provide setup-option^) diff --git a/collects/tests/mzscheme/embed-me2.ss b/collects/tests/mzscheme/embed-me2.ss index f0216b0381..53abb21299 100644 --- a/collects/tests/mzscheme/embed-me2.ss +++ b/collects/tests/mzscheme/embed-me2.ss @@ -1,6 +1,6 @@ (module embed-me2 mzscheme (require "embed-me1.ss" - (lib "etc.ss")) + mzlib/etc) (with-output-to-file "stdout" (lambda () (printf "This is 2: ~a~n" true)) 'append)) diff --git a/collects/tests/mzscheme/embed-me3.ss b/collects/tests/mzscheme/embed-me3.ss index a68cf78d4a..247292131a 100644 --- a/collects/tests/mzscheme/embed-me3.ss +++ b/collects/tests/mzscheme/embed-me3.ss @@ -1,5 +1,5 @@ (module embed-me3 mzscheme - (require (lib "etc.ss")) + (require mzlib/etc) (with-output-to-file "stdout" (lambda () (printf "3 is here, too? ~a\n" true)) diff --git a/collects/tests/mzscheme/embed-me5.ss b/collects/tests/mzscheme/embed-me5.ss index aaf471f21f..23c1fbe875 100644 --- a/collects/tests/mzscheme/embed-me5.ss +++ b/collects/tests/mzscheme/embed-me5.ss @@ -1,5 +1,5 @@ (module embed-me5 mzscheme - (require (lib "mred.ss" "mred")) + (require mred) (with-output-to-file "stdout" (lambda () (printf "This is 5: ~s\n" button%)) 'append)) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 191d4baffd..a86b85b7ab 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -3,10 +3,10 @@ (Section 'embed) -(require (lib "embed.ss" "compiler") - (lib "file.ss") - (lib "process.ss") - (lib "distribute.ss" "compiler")) +(require compiler/embed + mzlib/file + mzlib/process + compiler/distribute) (define (mk-dest-bin mred?) (case (system-type) @@ -220,8 +220,8 @@ (try-exe mr-dest "This is 5: #\n" #t)) ;; Try the mzc interface: -(require (lib "dirs.ss" "setup") - (lib "file.ss")) +(require setup/dirs + mzlib/file) (define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) "mzc.exe" "mzc"))) @@ -283,7 +283,7 @@ (mzc-tests #t) |# -(require (lib "file.ss" "dynext")) +(require dynext/file) (define (extension-test mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) From 6e98f88320870b92d0e83f046383af53a8f5a227 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 3 Mar 2008 22:04:28 +0000 Subject: [PATCH 066/466] revise the way setup-plt crawls over the collection trees svn: r8860 original commit: b76390a4523dd523febeab8f432f0341b6a2d040 --- collects/compiler/sig.ss | 157 +++++++++++++++++++-------------------- 1 file changed, 78 insertions(+), 79 deletions(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index b9577b6fa7..426dc6ee28 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -1,90 +1,89 @@ -(module sig mzscheme +#lang mzscheme - (require mzlib/unit) +(require mzlib/unit) - (provide compiler:option^ - compiler^ - compiler:inner^) +(provide compiler:option^ + compiler^ + compiler:inner^) - ;; Compiler options - (define-signature compiler:option^ - (verbose ; default = #f - - setup-prefix ; string to embed in public names; - ; used mainly for compiling extensions - ; with the collection name so that - ; cross-extension conflicts are less - ; likely in architectures that expose - ; the public names of loaded extensions - ; default = "" - - clean-intermediate-files ; #t => keep intermediate .c/.o files - ; default = #f +;; Compiler options +(define-signature compiler:option^ + (verbose ; default = #f - 3m ; #t => build for 3m - ; default = #f - - compile-subcollections ; #t => use 'compile-subcollections - ; from infor for collection compiling - ; default = #t - - compile-for-embedded ; #f => make objects to be linked + setup-prefix ; string to embed in public names; + ; used mainly for compiling extensions + ; with the collection name so that + ; cross-extension conflicts are less + ; likely in architectures that expose + ; the public names of loaded extensions + ; default = "" + + clean-intermediate-files ; #t => keep intermediate .c/.o files + ; default = #f + + 3m ; #t => build for 3m + ; default = #f + + compile-subcollections ; #t => compile collection subdirectories + ; default = #t + + compile-for-embedded ; #f => make objects to be linked ; directly with MzScheme, not dynamically ; loaded; default = #f - - max-inline-size ; max size of inlined procedures - - disable-interrupts ; #t => UNSAFE: turn off breaking, stack - ; overflow, and thread switching; - ; default = #f - unsafe ; #t => UNSAFE: omit some type checks - ; default = #f - fixnum-arithmetic ; #t => UNSAFE: don't check for overflow or - ; underflow for fixnum arithmetic; - ; default = #f - - propagate-constants ; default = #t - assume-primitives ; #t => car = #%car; default = #f - stupid ; allow obvious non-syntactic errors; - ; e.g.: ((lambda () 0) 1 2 3) - - vehicles ; Controls how closures are compiled: - ; 'vehicles:automatic, - ; 'vehicles:functions, - ; 'vechicles:units, or - ; 'vehicles:monolithic. - ; default = 'vehicles:automatic - vehicles:monoliths ; Size for 'vehicles:monolithic - seed ; Randomizer seed for 'vehicles:monolithic - - max-exprs-per-top-level-set ; Number of top-level Scheme expressions - ; crammed into one C function; default = 25 - - unpack-environments ; default = #t - ; Maybe #f helps for register-poor architectures? - - debug ; #t => creates debug.txt debugging file - test ; #t => ignores top-level expressions with syntax errors - )) - ;; Compiler procedures - (define-signature compiler^ - (compile-extensions - compile-extensions-to-c - compile-c-extensions + max-inline-size ; max size of inlined procedures - compile-zos + disable-interrupts ; #t => UNSAFE: turn off breaking, stack + ; overflow, and thread switching; + ; default = #f + unsafe ; #t => UNSAFE: omit some type checks + ; default = #f + fixnum-arithmetic ; #t => UNSAFE: don't check for overflow or + ; underflow for fixnum arithmetic; + ; default = #f - compile-collection-zos - compile-directory-zos - - current-compiler-dynamic-require-wrapper - compile-notify-handler)) + propagate-constants ; default = #t + assume-primitives ; #t => car = #%car; default = #f + stupid ; allow obvious non-syntactic errors; + ; e.g.: ((lambda () 0) 1 2 3) - ;; Low-level extension compiler interface - (define-signature compiler:inner^ - (compile-extension - compile-extension-to-c - compile-c-extension - eval-compile-prefix))) + vehicles ; Controls how closures are compiled: + ; 'vehicles:automatic, + ; 'vehicles:functions, + ; 'vechicles:units, or + ; 'vehicles:monolithic. + ; default = 'vehicles:automatic + vehicles:monoliths ; Size for 'vehicles:monolithic + seed ; Randomizer seed for 'vehicles:monolithic + + max-exprs-per-top-level-set ; Number of top-level Scheme expressions + ; crammed into one C function; default = 25 + + unpack-environments ; default = #t + ; Maybe #f helps for register-poor architectures? + + debug ; #t => creates debug.txt debugging file + test ; #t => ignores top-level expressions with syntax errors + )) + +;; Compiler procedures +(define-signature compiler^ + (compile-extensions + compile-extensions-to-c + compile-c-extensions + + compile-zos + + compile-collection-zos + compile-directory-zos + + current-compiler-dynamic-require-wrapper + compile-notify-handler)) + +;; Low-level extension compiler interface +(define-signature compiler:inner^ + (compile-extension + compile-extension-to-c + compile-c-extension + eval-compile-prefix)) From 876d31975bfd336ef3a7a95f344194a9ba0d759f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 16 Mar 2008 23:08:53 +0000 Subject: [PATCH 067/466] fix mac sdk support; change initial namespace to not have 'module'; set up mzc --c-mods (still need docs) svn: r8997 original commit: b64d03d93265a89530560bc3e2b08d9d4fbe8e40 --- collects/tests/mzscheme/embed.ss | 77 ++++++++++++++++++++------------ 1 file changed, 49 insertions(+), 28 deletions(-) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index a86b85b7ab..616eb4e9c8 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -86,6 +86,14 @@ expect mred?) (delete-directory/files dist-dir)])) +(define (base-compile e) + (parameterize ([current-namespace (make-base-namespace)]) + (compile e))) +(define (kernel-compile e) + (parameterize ([current-namespace (make-base-empty-namespace)]) + (namespace-require ''#%kernel) + (compile e))) + (define (mz-tests mred?) (define dest (if mred? mr-dest mz-dest)) (define (flags s) @@ -97,7 +105,7 @@ dest mred? #f `((#t (lib ,filename "tests" "mzscheme"))) null - null + #f `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) (try-exe dest expect mred?) @@ -111,9 +119,10 @@ `((,pfx (lib ,filename "tests" "mzscheme")) (#t (lib "scheme/init"))) null - null - `(,(flags "ne") - ,(format "(#%require '~a~a)" + #f + `(,(flags "lne") + "scheme/base" + ,(format "(require '~a~a)" (or pfx "") (regexp-replace #rx"[.].*$" filename "")))) (try-exe dest expect mred?))]) @@ -128,7 +137,8 @@ dest mred? #f `((#t ,path)) null - `(#%require (file ,(path->string path))) + (base-compile + `(namespace-require '(file ,(path->string path)))) `(,(flags "")))) (try-exe dest expect mred?) @@ -140,7 +150,8 @@ dest mred? #f `((#t (file ,(path->string path)))) null - `(#%require (file ,(path->string path))) + (base-compile + `(namespace-require '(file ,(path->string path)))) `(,(flags "")))) (try-exe dest expect mred?) @@ -152,7 +163,8 @@ dest mred? #f `((#f ,filename)) null - `(#%require ',(string->symbol (regexp-replace #rx"[.].*$" filename ""))) + (base-compile + `(namespace-require '',(string->symbol (regexp-replace #rx"[.].*$" filename "")))) `(,(flags "")))) (try-exe dest expect mred?) @@ -164,23 +176,33 @@ `((#t (lib ,filename "tests" "mzscheme")) (#t (lib "embed-me3.ss" "tests" "mzscheme"))) null - `(begin - (#%require (lib "embed-me3.ss" "tests" "mzscheme")) - (#%require (lib ,filename "tests" "mzscheme"))) + (base-compile + `(begin + (namespace-require '(lib "embed-me3.ss" "tests" "mzscheme")) + (namespace-require '(lib ,filename "tests" "mzscheme")))) `(,(flags ""))) (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) ;; Try a literal file (printf ">>>literal\n") (prepare dest filename) - (make-embedding-executable - dest mred? #f - `((#t (lib ,filename "tests" "mzscheme"))) - (list (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) - `(with-output-to-file "stdout" - (lambda () (display "... and more!\n")) - 'append) - `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) + (let ([tmp (make-temporary-file)]) + (with-output-to-file tmp + #:exists 'truncate + (lambda () + (write (kernel-compile + '(namespace-require ''#%kernel))))) + (make-embedding-executable + dest mred? #f + `((#t (lib ,filename "tests" "mzscheme"))) + (list + tmp + (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) + `(with-output-to-file "stdout" + (lambda () (display "... and more!\n")) + 'append) + `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) + (delete-file tmp)) (try-exe dest (string-append "This is the literal expression 4.\n" "... and more!\n" @@ -196,13 +218,14 @@ dest mred? #f '((#t scheme/base)) null - `(begin - (#%require scheme/base) - (define (out s) - (with-output-to-file "stdout" - (lambda () (printf s)) - #:exists 'append)) - (out "\uA9, \u7238, and \U1D670\n")) + (base-compile + '(begin + (require scheme/base) + (eval '(define (out s) + (with-output-to-file "stdout" + (lambda () (printf s)) + #:exists 'append))) + (out "\uA9, \u7238, and \U1D670\n"))) `(,(flags "ne") "(out \"\u7237...\U1D671\n\")")) (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) @@ -215,7 +238,7 @@ mr-dest #t #f `((#t (lib "embed-me5.ss" "tests" "mzscheme"))) null - null + #f `("-l" "tests/mzscheme/embed-me5.ss")) (try-exe mr-dest "This is 5: #\n" #t)) @@ -278,10 +301,8 @@ (void))) -#| REMOVEME (mzc-tests #f) (mzc-tests #t) -|# (require dynext/file) (define (extension-test mred?) From 6bbd79d0b704897aba7f750bd16478505db602ab Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 9 Jul 2008 07:18:06 +0000 Subject: [PATCH 068/466] * Newlines at EOFs * Another big chunk of v4-require-isms * Allow `#lang framework/keybinding-lang' for keybinding files * Move hierlist sources into "mrlib/hierlist", leave stub behind svn: r10689 original commit: 7d50e61c7f6831936e13e6af5140db65db18fe1c --- collects/tests/mzscheme/embed-me10.ss | 2 +- collects/tests/mzscheme/embed-me6.ss | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/mzscheme/embed-me10.ss b/collects/tests/mzscheme/embed-me10.ss index 807eb8705d..70360977d6 100644 --- a/collects/tests/mzscheme/embed-me10.ss +++ b/collects/tests/mzscheme/embed-me10.ss @@ -1,5 +1,5 @@ (module embed-me10 mzscheme - (require (lib "mzssl.ss" "openssl")) + (require openssl/mzssl) (with-output-to-file "stdout" (lambda () diff --git a/collects/tests/mzscheme/embed-me6.ss b/collects/tests/mzscheme/embed-me6.ss index 74ec1f8354..58a244aee1 100644 --- a/collects/tests/mzscheme/embed-me6.ss +++ b/collects/tests/mzscheme/embed-me6.ss @@ -3,6 +3,6 @@ (lambda () (printf "This is 6\n") (with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))]) - (printf "~a\n" (dynamic-require '(lib "etc.ss") 'true)))) + (printf "~a\n" (dynamic-require 'mzlib/etc 'true)))) 'append)) From da32616652dabc72d8e7f1dcd901cd4a2d1c581b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 Aug 2008 22:28:08 +0000 Subject: [PATCH 069/466] add with-cont-mark decompilation svn: r11306 original commit: 6a0a40773bee8916051584e813c41a75284bf999 --- collects/compiler/decompile.ss | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 33144f5eed..1448bb138d 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -248,6 +248,11 @@ [(struct beg0 (exprs)) `(begin0 ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack)))] + [(struct with-cont-mark (key val body)) + `(with-continuation-mark + ,(decompile-expr key globs stack) + ,(decompile-expr val globs stack) + ,(decompile-expr body globs stack))] [(struct closure (lam gen-id)) `(CLOSED ,gen-id ,(decompile-expr lam globs stack))] [(struct indirect (val)) From 19a098a7fa800e9f5b8b67a56307edcb76f55474 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 Aug 2008 22:34:38 +0000 Subject: [PATCH 070/466] expose safe-for-space clearing in decompilation svn: r11307 original commit: e611829b768ababc5d5d8860565231a4ac8310e7 --- collects/compiler/decompile.ss | 19 +++++++++++-------- collects/compiler/zo-parse.ss | 16 ++++++++++------ 2 files changed, 21 insertions(+), 14 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 1448bb138d..e1e9ffaf88 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -75,7 +75,7 @@ (if (null? stx-ids) null '(#%stx-array)) lift-ids) (map (lambda (stx id) - `(define ,id (decode-stx ,(stx-encoded stx)))) + `(define ,id (#%decode-syntax ,(stx-encoded stx)))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -174,11 +174,14 @@ [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack) ,(decompile-expr rhs globs stack))] - [(struct localref (unbox? offset flags)) + [(struct localref (unbox? offset clear?)) (let ([id (list-ref/protect stack offset)]) - (if unbox? - `(#%unbox ,id) - id))] + (let ([e (if unbox? + `(#%unbox ,id) + id)]) + (if clear? + `(#%sfs-clear ,e) + e)))] [(struct lam (name flags num-params rest? closure-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)]) (gensym 'arg))] [rest-vars (if rest? (list (gensym 'rest)) null)]) @@ -240,8 +243,8 @@ (decompile-expr rand globs stack)) rands)))] [(struct apply-values (proc args-expr)) - `(apply-values ,(decompile-expr proc globs stack) - ,(decompile-expr args-expr globs stack))] + `(#%apply-values ,(decompile-expr proc globs stack) + ,(decompile-expr args-expr globs stack))] [(struct sequence (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack)))] @@ -254,7 +257,7 @@ ,(decompile-expr val globs stack) ,(decompile-expr body globs stack))] [(struct closure (lam gen-id)) - `(CLOSED ,gen-id ,(decompile-expr lam globs stack))] + `(#%closed ,gen-id ,(decompile-expr lam globs stack))] [(struct indirect (val)) (if (closure? val) (closure-gen-id val) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 8007070022..a739445462 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -35,7 +35,7 @@ (define-form-struct let-rec (procs body)) ; put `letrec'-bound closures into existing stack slots (define-form-struct boxenv (pos body)) ; box existing stack element -(define-form-struct localref (unbox? offset flags)) ; access local via stack +(define-form-struct localref (unbox? offset clear?)) ; access local via stack (define-form-struct toplevel (depth pos flags)) ; access binding via prefix array (which is on stack) (define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack) @@ -408,6 +408,10 @@ [reader (get-reader type)]) (reader l))) +(define (make-local unbox? pos flags) + (define SCHEME_LOCAL_CLEAR_ON_READ #x01) + (make-localref unbox? pos (positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ)))) + (define (a . << . b) (arithmetic-shift a b)) @@ -482,7 +486,7 @@ [flags (if (< p* 0) (read-compact-number cp) 0)]) - (make-localref #t p flags))] + (make-local #t p flags))] [(path) (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))]) (if (relative-path? p) @@ -527,12 +531,12 @@ (let ([c (read-compact-number cp)] [unbox? (eq? cpt-tag 'local-unbox)]) (if (negative? c) - (make-localref unbox? (- (add1 c)) (read-compact-number cp)) - (make-localref unbox? c 0)))] + (make-local unbox? (- (add1 c)) (read-compact-number cp)) + (make-local unbox? c 0)))] [(small-local) - (make-localref #f (- ch cpt-start) 0)] + (make-local #f (- ch cpt-start) 0)] [(small-local-unbox) - (make-localref #t (- ch cpt-start) 0)] + (make-local #t (- ch cpt-start) 0)] [(small-symbol) (let ([l (- ch cpt-start)]) (string->symbol (read-compact-chars cp l)))] From 436c1a119ad76286a5f9a2e93d6a6ed91607a592 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Aug 2008 00:04:20 +0000 Subject: [PATCH 071/466] add --decompile blade to mzc and refine decompiler output svn: r11310 original commit: 64c655a51669a9778b3f7e2cfed02dd4d4e908ed --- collects/compiler/decompile.ss | 56 ++++++++++++++++++++-------------- collects/compiler/zo-parse.ss | 24 ++++++++++----- 2 files changed, 50 insertions(+), 30 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index e1e9ffaf88..95aab6ec6a 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -33,20 +33,18 @@ #; (if (pos . < . (length l)) (list-ref l pos) - 'OUT-OF-BOUNDS)) + `(OUT-OF-BOUNDS ,pos ,l))) ;; ---------------------------------------- ;; Main entry: (define (decompile top) (match top - [(struct compilation-top (_ prefix (and (? mod?) mod))) - (decompile-module mod)] [(struct compilation-top (_ prefix form)) (let-values ([(globs defns) (decompile-prefix prefix)]) `(begin ,@defns - ,(decompile-form form globs '(#%prefix))))] + ,(decompile-form form globs '(#%globals))))] [else (error 'decompile "unrecognized: ~e" top)])) (define (decompile-prefix a-prefix) @@ -59,13 +57,15 @@ (values (append (map (lambda (tl) (match tl - [(struct global-bucket (name)) name] + [(? symbol?) '#%linkage] + [(struct global-bucket (name)) + (string->symbol (format "_~a" name))] [(struct module-variable (modidx sym pos phase)) (if (and (module-path-index? modidx) (let-values ([(n b) (module-path-index-split modidx)]) (and (not n) (not b)))) - sym - (string->symbol (format "~s@~s~a" sym (mpi->string modidx) + (string->symbol (format "_~a" sym)) + (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) (if (zero? phase) "" (format "/~a" phase)))))] @@ -84,26 +84,29 @@ [(symbol? modidx) modidx] [else (collapse-module-path-index modidx (current-directory))])) -(define (decompile-module mod-form) +(define (decompile-module mod-form stack) (match mod-form [(struct mod (name self-modidx prefix provides requires body syntax-body)) - (let-values ([(globs defns) (decompile-prefix prefix)]) + (let-values ([(globs defns) (decompile-prefix prefix)] + [(stack) (append '(#%modvars) stack)]) `(module ,name .... ,@defns ,@(map (lambda (form) - (decompile-form form globs '(#%prefix))) + (decompile-form form globs stack)) syntax-body) ,@(map (lambda (form) - (decompile-form form globs '(#%prefix))) + (decompile-form form globs stack)) body)))] [else (error 'decompile-module "huh?: ~e" mod-form)])) (define (decompile-form form globs stack) (match form + [(? mod?) + (decompile-module form stack)] [(struct def-values (ids rhs)) `(define-values ,(map (lambda (tl) (match tl - [(struct toplevel (depth pos flags)) + [(struct toplevel (depth pos const? mutated?)) (list-ref/protect globs pos)])) ids) ,(decompile-expr rhs globs stack))] @@ -112,13 +115,13 @@ ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-expr rhs globs '(#%prefix)))))] + ,(decompile-expr rhs globs '(#%globals)))))] [(struct def-for-syntax (ids rhs prefix max-let-depth)) `(define-values-for-syntax ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-expr rhs globs '(#%prefix)))))] + ,(decompile-expr rhs globs '(#%globals)))))] [(struct sequence (forms)) `(begin ,@(map (lambda (form) (decompile-form form globs stack)) @@ -165,8 +168,11 @@ (define (decompile-expr expr globs stack) (match expr - [(struct toplevel (depth pos flags)) - (list-ref/protect globs pos)] + [(struct toplevel (depth pos const? mutated?)) + (let ([id (list-ref/protect globs pos)]) + (if const? + id + `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) (list-ref/protect globs (+ midpt pos))] [(struct primitive (id)) @@ -183,19 +189,23 @@ `(#%sfs-clear ,e) e)))] [(struct lam (name flags num-params rest? closure-map max-let-depth body)) - (let ([vars (for/list ([i (in-range num-params)]) (gensym 'arg))] - [rest-vars (if rest? (list (gensym 'rest)) null)]) + (let ([vars (for/list ([i (in-range num-params)]) + (gensym (format "arg~a-" i)))] + [rest-vars (if rest? (list (gensym 'rest)) null)] + [captures (map (lambda (v) + (list-ref/protect stack v)) + (vector->list closure-map))]) `(lambda (,@vars . ,(if rest? (car rest-vars) null)) ,@(if name `(',name) null) - ,(decompile-expr body globs (append - (map (lambda (v) - (list-ref/protect stack v)) - (vector->list closure-map)) - (append vars rest-vars)))))] + ,@(if (null? captures) + null + `('(captures: ,@captures))) + ,(decompile-expr body globs (append captures + (append vars rest-vars)))))] [(struct let-one (rhs body)) (let ([id (or (extract-id rhs) (gensym 'local))]) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index a739445462..98528bbfa4 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -37,7 +37,7 @@ (define-form-struct localref (unbox? offset clear?)) ; access local via stack -(define-form-struct toplevel (depth pos flags)) ; access binding via prefix array (which is on stack) +(define-form-struct toplevel (depth pos const? mutated?)) ; access binding via prefix array (which is on stack) (define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack) (define-form-struct application (rator rands)) ; function call @@ -67,12 +67,15 @@ ;; Bytecode unmarshalers for various forms (define (read-toplevel v) - (define toplevel-flags-mask 3) + (define SCHEME_TOPLEVEL_CONST #x01) + (define SCHEME_TOPLEVEL_MUTATED #x02) (match v [(cons depth (cons pos flags)) - (make-toplevel depth pos (bitwise-and flags toplevel-flags-mask))] + (make-toplevel depth pos + (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) + (positive? (bitwise-and flags SCHEME_TOPLEVEL_MUTATED)))] [(cons depth pos) - (make-toplevel depth pos 0)])) + (make-toplevel depth pos #f #f)])) (define (read-topsyntax v) (match v @@ -112,13 +115,17 @@ (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) (let-values ([(closure-size closed-over body) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - (values #f v rest) + (values (vector-length v) v rest) (values v (car rest) (cdr rest)))]) (make-lam name flags ((if rest? sub1 values) num-params) rest? - closed-over + (if (= closure-size (vector-length closed-over)) + closed-over + (let ([v2 (make-vector closure-size)]) + (vector-copy! v2 0 closed-over 0 closure-size) + v2)) max-let-depth body)))])) @@ -252,6 +259,7 @@ [(14) 'with-cont-mark-type] [(15) 'quote-syntax-type] [(24) 'variable-type] + [(25) 'module-variable-type] [(96) 'case-lambda-sequence-type] [(97) 'begin0-sequence-type] [(100) 'module-type] @@ -271,6 +279,7 @@ (cons 'with-cont-mark-type read-with-cont-mark) (cons 'quote-syntax-type read-topsyntax) (cons 'variable-type read-variable) + (cons 'module-variable-type read-variable) (cons 'compilation-top-type read-compilation-top) (cons 'case-lambda-sequence-type read-case-lambda) (cons 'begin0-sequence-type read-sequence) @@ -625,7 +634,8 @@ (define (zo-parse port) (begin-with-definitions ;; skip the "#~" - (read-bytes 2 port) + (unless (equal? #"#~" (read-bytes 2 port)) + (error 'zo-parse "not a bytecode stream")) (define version (read-bytes (min 63 (read-byte port)) port)) From ba4152303680f16b1b65e466a5a3d3d1e67ac6a4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Aug 2008 00:50:52 +0000 Subject: [PATCH 072/466] document 'mzc --decompile' svn: r11317 original commit: 76cf25fc12ea4bf1ce9c9fdb450e74b96873082f --- collects/compiler/decompile.ss | 60 ++++++++++++++++++++-------------- collects/compiler/zo-parse.ss | 2 +- 2 files changed, 36 insertions(+), 26 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 95aab6ec6a..3beb726fbd 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -115,7 +115,7 @@ ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-expr rhs globs '(#%globals)))))] + ,(decompile-form rhs globs '(#%globals)))))] [(struct def-for-syntax (ids rhs prefix max-let-depth)) `(define-values-for-syntax ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) @@ -188,24 +188,13 @@ (if clear? `(#%sfs-clear ,e) e)))] - [(struct lam (name flags num-params rest? closure-map max-let-depth body)) - (let ([vars (for/list ([i (in-range num-params)]) - (gensym (format "arg~a-" i)))] - [rest-vars (if rest? (list (gensym 'rest)) null)] - [captures (map (lambda (v) - (list-ref/protect stack v)) - (vector->list closure-map))]) - `(lambda (,@vars . ,(if rest? - (car rest-vars) - null)) - ,@(if name - `(',name) - null) - ,@(if (null? captures) - null - `('(captures: ,@captures))) - ,(decompile-expr body globs (append captures - (append vars rest-vars)))))] + [(? lam?) + `(lambda . ,(decompile-lam expr globs stack))] + [(struct case-lam (name lams)) + `(case-lambda + ,@(map (lambda (lam) + (decompile-lam lam globs stack)) + lams))] [(struct let-one (rhs body)) (let ([id (or (extract-id rhs) (gensym 'local))]) @@ -222,12 +211,12 @@ ,(decompile-expr body globs (append vars stack)))))] [(struct let-rec (procs body)) `(begin - (set!-rec-values ,(for/list ([p (in-list procs)] - [i (in-naturals)]) - (list-ref/protect stack i)) - ,@(map (lambda (proc) - (decompile-expr proc globs stack)) - procs)) + (#%set!-rec-values ,(for/list ([p (in-list procs)] + [i (in-naturals)]) + (list-ref/protect stack i)) + ,@(map (lambda (proc) + (decompile-expr proc globs stack)) + procs)) ,(decompile-expr body globs stack))] [(struct install-value (count pos boxes? rhs body)) `(begin @@ -274,6 +263,27 @@ '???)] [else `(quote ,expr)])) +(define (decompile-lam expr globs stack) + (match expr + [(struct lam (name flags num-params rest? closure-map max-let-depth body)) + (let ([vars (for/list ([i (in-range num-params)]) + (gensym (format "arg~a-" i)))] + [rest-vars (if rest? (list (gensym 'rest)) null)] + [captures (map (lambda (v) + (list-ref/protect stack v)) + (vector->list closure-map))]) + `((,@vars . ,(if rest? + (car rest-vars) + null)) + ,@(if (and name (not (null? name))) + `(',name) + null) + ,@(if (null? captures) + null + `('(captures: ,@captures))) + ,(decompile-expr body globs (append captures + (append vars rest-vars)))))])) + ;; ---------------------------------------- #; diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 98528bbfa4..7bcefcbde9 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -235,7 +235,7 @@ [(0) (read-define-values v)] [(1) (read-define-syntax v)] [(2) (read-set! v)] - [(3) (read-case-lambda v)] + [(3) v] ; a case-lam already [(4) (read-begin0 v)] [(5) (read-boxenv v)] [(6) (read-module-wrap v)] From 9ed7e7ba98fe3b7529fd6f8d442a0e5fb2a8f260 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Aug 2008 15:18:09 +0000 Subject: [PATCH 073/466] fix letrec compilation when call/cc is used on the RHS of something that otherwise looks like it could be let*; add #%in annotations to decompiler output svn: r11329 original commit: ebab4270bf9e23abed341e4f2c37877f3cbb00c8 --- collects/compiler/decompile.ss | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 3beb726fbd..4c009cdcd1 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -237,10 +237,11 @@ [(struct application (rator rands)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) stack)]) - `(,(decompile-expr rator globs stack) - ,@(map (lambda (rand) - (decompile-expr rand globs stack)) - rands)))] + (annotate-inline + `(,(decompile-expr rator globs stack) + ,@(map (lambda (rand) + (decompile-expr rand globs stack)) + rands))))] [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack) ,(decompile-expr args-expr globs stack))] @@ -284,6 +285,28 @@ ,(decompile-expr body globs (append captures (append vars rest-vars)))))])) +(define (annotate-inline a) + (if (and (symbol? (car a)) + (case (length a) + [(2) (memq (car a) '(not null? pair? mpair? symbol? + syntax? char? boolean? + number? real? exact-integer? + fixnum? inexact-real? + procedure? vector? box? string? bytes? eof-object? + zero? negative? exact-nonnegative-integer? + exact-positive-integer? + car cdr caar cadr cdar cddr + mcar mcdr unbox syntax-e + add1 sub1 - abs bitwise-not))] + [(3) (memq (car a) '(eq? = <= < >= > + bitwise-bit-set? char=? + + - * / min max bitwise-and bitwise-ior + arithmetic-shift vector-ref string-ref bytes-ref + set-mcar! set-mcdr! cons mcons))] + [(4) (memq (car a) '(vector-set! string-set! bytes-set!))])) + (cons '#%in a) + a)) + ;; ---------------------------------------- #; From 9794d09d5637244c29bc8b1e691e6964af41288f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Oct 2008 16:00:36 +0000 Subject: [PATCH 074/466] fix bug in exe creation where 'lib runtime-paths could be mis-parsed as mzlib paths svn: r11966 original commit: 89f23153745a2f7fb811ee21fb52f968f2e000be --- collects/tests/mzscheme/embed-me1b.ss | 9 ++ collects/tests/mzscheme/embed-me1c.ss | 9 ++ collects/tests/mzscheme/embed.ss | 157 +++++++++++++------------- 3 files changed, 98 insertions(+), 77 deletions(-) create mode 100644 collects/tests/mzscheme/embed-me1b.ss create mode 100644 collects/tests/mzscheme/embed-me1c.ss diff --git a/collects/tests/mzscheme/embed-me1b.ss b/collects/tests/mzscheme/embed-me1b.ss new file mode 100644 index 0000000000..5af91026b6 --- /dev/null +++ b/collects/tests/mzscheme/embed-me1b.ss @@ -0,0 +1,9 @@ +#lang scheme/base + +(require scheme/runtime-path + (for-syntax scheme/base)) +(define-runtime-path file '(lib "icons/file.gif")) +(with-output-to-file "stdout" + (lambda () (printf "This is 1b~n")) + #:exists 'append) + diff --git a/collects/tests/mzscheme/embed-me1c.ss b/collects/tests/mzscheme/embed-me1c.ss new file mode 100644 index 0000000000..067c8ad230 --- /dev/null +++ b/collects/tests/mzscheme/embed-me1c.ss @@ -0,0 +1,9 @@ +#lang scheme/base + +(require scheme/runtime-path + (for-syntax scheme/base)) +(define-runtime-path file '(lib "etc.ss")) ; in mzlib +(with-output-to-file "stdout" + (lambda () (printf "This is 1c~n")) + #:exists 'append) + diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index 616eb4e9c8..cf4963ac63 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -98,7 +98,7 @@ (define dest (if mred? mr-dest mz-dest)) (define (flags s) (string-append "-" s)) - (define (one-mz-test filename expect) + (define (one-mz-test filename expect literal?) ;; Try simple mode: one module, launched from cmd line: (prepare dest filename) (make-embedding-executable @@ -129,88 +129,91 @@ (w/prefix #f) (w/prefix 'before:)) - ;; Try full path, and use literal S-exp to start - (printf ">>>literal sexp\n") - (prepare dest filename) - (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (when literal? + ;; Try full path, and use literal S-exp to start + (printf ">>>literal sexp\n") + (prepare dest filename) + (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (make-embedding-executable + dest mred? #f + `((#t ,path)) + null + (base-compile + `(namespace-require '(file ,(path->string path)))) + `(,(flags "")))) + (try-exe dest expect mred?) + + ;; Use `file' form: + (printf ">>>file\n") + (prepare dest filename) + (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (make-embedding-executable + dest mred? #f + `((#t (file ,(path->string path)))) + null + (base-compile + `(namespace-require '(file ,(path->string path)))) + `(,(flags "")))) + (try-exe dest expect mred?) + + ;; Use relative path + (printf ">>>relative path\n") + (prepare dest filename) + (parameterize ([current-directory (collection-path "tests" "mzscheme")]) + (make-embedding-executable + dest mred? #f + `((#f ,filename)) + null + (base-compile + `(namespace-require '',(string->symbol (regexp-replace #rx"[.].*$" filename "")))) + `(,(flags "")))) + (try-exe dest expect mred?) + + ;; Try multiple modules + (printf ">>>multiple\n") + (prepare dest filename) (make-embedding-executable dest mred? #f - `((#t ,path)) + `((#t (lib ,filename "tests" "mzscheme")) + (#t (lib "embed-me3.ss" "tests" "mzscheme"))) null (base-compile - `(namespace-require '(file ,(path->string path)))) - `(,(flags "")))) - (try-exe dest expect mred?) + `(begin + (namespace-require '(lib "embed-me3.ss" "tests" "mzscheme")) + (namespace-require '(lib ,filename "tests" "mzscheme")))) + `(,(flags ""))) + (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) - ;; Use `file' form: - (printf ">>>file\n") - (prepare dest filename) - (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) - (make-embedding-executable - dest mred? #f - `((#t (file ,(path->string path)))) - null - (base-compile - `(namespace-require '(file ,(path->string path)))) - `(,(flags "")))) - (try-exe dest expect mred?) + ;; Try a literal file + (printf ">>>literal\n") + (prepare dest filename) + (let ([tmp (make-temporary-file)]) + (with-output-to-file tmp + #:exists 'truncate + (lambda () + (write (kernel-compile + '(namespace-require ''#%kernel))))) + (make-embedding-executable + dest mred? #f + `((#t (lib ,filename "tests" "mzscheme"))) + (list + tmp + (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) + `(with-output-to-file "stdout" + (lambda () (display "... and more!\n")) + 'append) + `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) + (delete-file tmp)) + (try-exe dest (string-append + "This is the literal expression 4.\n" + "... and more!\n" + expect) + mred?))) - ;; Use relative path - (printf ">>>relative path\n") - (prepare dest filename) - (parameterize ([current-directory (collection-path "tests" "mzscheme")]) - (make-embedding-executable - dest mred? #f - `((#f ,filename)) - null - (base-compile - `(namespace-require '',(string->symbol (regexp-replace #rx"[.].*$" filename "")))) - `(,(flags "")))) - (try-exe dest expect mred?) - - ;; Try multiple modules - (printf ">>>multiple\n") - (prepare dest filename) - (make-embedding-executable - dest mred? #f - `((#t (lib ,filename "tests" "mzscheme")) - (#t (lib "embed-me3.ss" "tests" "mzscheme"))) - null - (base-compile - `(begin - (namespace-require '(lib "embed-me3.ss" "tests" "mzscheme")) - (namespace-require '(lib ,filename "tests" "mzscheme")))) - `(,(flags ""))) - (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) - - ;; Try a literal file - (printf ">>>literal\n") - (prepare dest filename) - (let ([tmp (make-temporary-file)]) - (with-output-to-file tmp - #:exists 'truncate - (lambda () - (write (kernel-compile - '(namespace-require ''#%kernel))))) - (make-embedding-executable - dest mred? #f - `((#t (lib ,filename "tests" "mzscheme"))) - (list - tmp - (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) - `(with-output-to-file "stdout" - (lambda () (display "... and more!\n")) - 'append) - `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) - (delete-file tmp)) - (try-exe dest (string-append - "This is the literal expression 4.\n" - "... and more!\n" - expect) - mred?)) - - (one-mz-test "embed-me1.ss" "This is 1\n") - (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n") + (one-mz-test "embed-me1.ss" "This is 1\n" #t) + (one-mz-test "embed-me1b.ss" "This is 1b\n" #f) + (one-mz-test "embed-me1c.ss" "This is 1c\n" #f) + (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n" #t) ;; Try unicode expr and cmdline: (prepare dest "unicode") From 128081a8e97247e5e9298e7c6b96717d7125940a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Oct 2008 22:23:56 +0000 Subject: [PATCH 075/466] unit bug fixes related to new scoping of signature elements; change scribble/manual to compute ids typeset as variables at compile time, in preparation for moving from a parameter to syntax bindings; fix docs typos; extend decompiler's support for unmarshaling syntax objects svn: r12046 original commit: 7a55275a26f4052af6ec87f2737f367721abc4ec --- collects/compiler/decompile.ss | 1 + collects/compiler/zo-parse.ss | 124 ++++++++++++++++++++++++++++++++- 2 files changed, 122 insertions(+), 3 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 4c009cdcd1..aa851a4052 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -266,6 +266,7 @@ (define (decompile-lam expr globs stack) (match expr + [(struct closure (lam gen-id)) (decompile-lam lam globs stack)] [(struct lam (name flags num-params rest? closure-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)]) (gensym (format "arg~a-" i)))] diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index cc44ec16fe..f73b98d2ce 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -306,7 +306,7 @@ ;; not sure if it's really unsigned (integer-bytes->integer (read-bytes 4 p) #f #f)) -(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets)) +(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns)) (define (cp-getc cp) (begin-with-definitions @@ -426,6 +426,124 @@ (define-struct not-ready ()) +;; ---------------------------------------- +;; Synatx unmarshaling + +(define-form-struct wrapped (datum wraps certs)) + +(define (decode-stx cp v) + (if (integer? v) + (let-values ([(v2 decoded?) (unmarshal-stx-get cp v)]) + (if decoded? + v2 + (let ([v2 (decode-stx cp v2)]) + (unmarshal-stx-set! cp v v2) + v2))) + (let loop ([v v]) + (let-values ([(cert-marks v encoded-wraps) + (match v + [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] + [`(,datum . ,wraps) (values #f datum wraps)] + [else (error 'decode-wraps "bad datum+wrap: ~e" v)])]) + (let* ([wraps (decode-wraps cp encoded-wraps)] + [add-wrap (lambda (v) (make-wrapped v wraps cert-marks))]) + (cond + [(pair? v) + (if (eq? #t (car v)) + ;; Share decoded wraps with all nested parts. + (let loop ([v (cdr v)]) + (cond + [(pair? v) + (let ploop ([v v]) + (cond + [(null? v) null] + [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] + [else (loop v)]))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (cdr (vector->list (struct->vector v)))))))] + [else (add-wrap v)])) + ;; Decode sub-elements that have their own wraps: + (let-values ([(v counter) (if (exact-integer? (car v)) + (values (cdr v) (car v)) + (values v -1))]) + (add-wrap + (let ploop ([v v][counter counter]) + (cond + [(null? v) null] + [(or (not (pair? v)) (zero? counter)) (loop v)] + [(pair? v) (cons (loop (car v)) + (ploop (cdr v) (sub1 counter)))])))))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (cdr (vector->list (struct->vector v)))))))] + [else (add-wrap v)])))))) + +(define (decode-wraps cp w) + (if (integer? w) + (let-values ([(w2 decoded?) (unmarshal-stx-get cp w)]) + (if decoded? + w2 + (let ([w2 (decode-wraps cp w2)]) + (unmarshal-stx-set! cp w w2) + w2))) + (map (lambda (a) + (let aloop ([a a]) + (cond + [(integer? a) + (let-values ([(a2 decoded?) (unmarshal-stx-get cp a)]) + (if decoded? + a2 + (let ([a2 (aloop a2)]) + (unmarshal-stx-set! cp a a2) + a2)))] + [(and (pair? a) (null? (cdr a)) (number? (car a))) + ;; a mark + (string->symbol (format "mark~a" (car a)))] + [(vector? a) + `(#%decode-lexical-rename ,a)] + [(pair? a) + `(#%decode-module-rename ,a)] + [(boolean? a) + `(#%top-level-rename ,a)] + [(symbol? a) + '(#%mark-barrier)] + [(box? a) + `(#%phase-shift ,(unbox a))] + [else (error 'decode-wraps "bad wrap element: ~e" a)]))) + w))) + +(define (unmarshal-stx-get cp pos) + (if (pos . >= . (vector-length (cport-symtab cp))) + (values `(#%bad-index ,pos) #t) + (let ([v (vector-ref (cport-symtab cp) pos)]) + (if (not-ready? v) + (let ([save-pos (cport-pos cp)]) + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) + (let ([v (read-compact cp)]) + (vector-set! (cport-symtab cp) pos v) + (set-cport-pos! cp save-pos) + (values v #f))) + (values v (vector-ref (cport-decoded cp) pos)))))) + +(define (unmarshal-stx-set! cp pos v) + (vector-set! (cport-symtab cp) pos v) + (vector-set! (cport-decoded cp) pos #t)) + ;; ---------------------------------------- ;; Main parsing loop @@ -535,7 +653,7 @@ [(marshalled) (read-marshalled (read-compact-number cp) cp)] [(stx) (let ([v (make-reader-graph (read-compact cp))]) - (make-stx v))] + (make-stx (decode-stx cp v)))] [(local local-unbox) (let ([c (read-compact-number cp)] [unbox? (eq? cpt-tag 'local-unbox)]) @@ -666,7 +784,7 @@ (define symtab (make-vector symtabsize (make-not-ready))) - (define cp (make-cport 0 port size* rst symtab so*)) + (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) (when (not-ready? (vector-ref symtab i)) (set-cport-pos! cp (vector-ref so* (sub1 i))) From 67030288cdaefe3d8ceb562c189c513d3e2b4137 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Oct 2008 00:10:47 +0000 Subject: [PATCH 076/466] finish decompiler on syntax objects svn: r12077 original commit: e2d4bc0d2bd46db59dbb5cbf0eda94f47c491719 --- collects/compiler/decompile.ss | 7 +- collects/compiler/zo-parse.ss | 121 +++++++++++++++++++++++++++++++-- 2 files changed, 121 insertions(+), 7 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index aa851a4052..5f1248b43e 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -75,7 +75,9 @@ (if (null? stx-ids) null '(#%stx-array)) lift-ids) (map (lambda (stx id) - `(define ,id (#%decode-syntax ,(stx-encoded stx)))) + `(define ,id ,(if stx + `(#%decode-syntax ,(stx-encoded stx)) + #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -304,7 +306,8 @@ + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons))] - [(4) (memq (car a) '(vector-set! string-set! bytes-set!))])) + [(4) (memq (car a) '(vector-set! string-set! bytes-set!))] + [else #f])) (cons '#%in a) a)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index f73b98d2ce..29b7b76f5b 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -306,7 +306,7 @@ ;; not sure if it's really unsigned (integer-bytes->integer (read-bytes 4 p) #f #f)) -(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns)) +(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns mpis)) (define (cp-getc cp) (begin-with-definitions @@ -430,6 +430,11 @@ ;; Synatx unmarshaling (define-form-struct wrapped (datum wraps certs)) +(define-form-struct lexical-rename (alist)) +(define-form-struct phase-shift (amt src dest)) +(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) +(define-form-struct all-from-module (path phase src-phase exceptions prefix)) +(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id)) (define (decode-stx cp v) (if (integer? v) @@ -515,15 +520,107 @@ ;; a mark (string->symbol (format "mark~a" (car a)))] [(vector? a) - `(#%decode-lexical-rename ,a)] + (make-lexical-rename + (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) + (let loop ([i 2]) + (if (= i top) + null + (cons (cons (vector-ref a i) + (vector-ref a (+ (- top 2) i))) + (loop (+ i 1)))))))] [(pair? a) - `(#%decode-module-rename ,a)] + (let-values ([(plus-kern? a) (if (eq? (car a) #t) + (values #t (cdr a)) + (values #f a))]) + (match a + [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) + (let-values ([(unmarshals renames mark-renames) + (if (vector? maybe-unmarshals) + (values null maybe-unmarshals renames) + (values maybe-unmarshals + (car renames) + (cdr renames)))]) + (make-module-rename phase + (if kind 'marked 'normal) + set-id + (map (lambda (u) + (let ([just-phase? (number? (cddr u))]) + (let-values ([(exns prefix) + (if just-phase? + (values null #f) + (let loop ([u (if just-phase? null (cdddr u))] + [a null]) + (if (pair? u) + (loop (cdr u) (cons (car u) a)) + (values (reverse a) u))))]) + (make-all-from-module + (parse-module-path-index cp (car u)) + (cadr u) + (if just-phase? + (cddr u) + (caddr u)) + exns + prefix)))) + unmarshals) + (let loop ([i 0]) + (if (= i (vector-length renames)) + null + (cons + (let ([key (vector-ref renames i)] + [make-mapping + (lambda (path mod-phase import-phase id nominal-path nominal-phase nominal-id) + (make-module-binding + (parse-module-path-index cp path) + mod-phase + import-phase + id + (parse-module-path-index cp nominal-path) + nominal-phase + (if (eq? id nominal-id) #t nominal-id)))]) + (cons key + (let ([m (vector-ref renames (add1 i))] + [parse-nominal-modidx-plus-phase + (lambda (modidx mod-phase exportname nominal-modidx-plus-phase nom-exportname) + (match nominal-modidx-plus-phase + [`(,nominal-modidx ,import-phase-plus-nominal-phase) + (match import-phase-plus-nominal-phase + [`(,import-phase ,nom-phase) + (make-mapping modidx mod-phase import-phase exportname + nominal-modidx nom-phase nom-exportname)] + [import-phase + (make-mapping modidx mod-phase import-phase exportname + modidx mod-phase nom-exportname)])] + [nominal-modidx + (make-mapping modidx mod-phase '* exportname + nominal-modidx mod-phase nom-exportname)]))]) + (match m + [`(,modidx ,mod-phase ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname) + (parse-nominal-modidx-plus-phase modidx mod-phase exportname + nominal-modidx-plus-phase nominal-exportname)] + [`(,modidx ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname) + (parse-nominal-modidx-plus-phase modidx '* exportname + nominal-modidx-plus-phase nominal-exportname)] + [`(,modidx ,nominal-modidx) + (make-mapping modidx '* '* key nominal-modidx '* key)] + [`(,modidx ,exportname) + (make-mapping modidx '* '* exportname modidx '* exportname)] + [modidx + (make-mapping modidx '* '* key modidx '* key)])))) + (loop (+ i 2))))) + mark-renames + (and plus-kern? 'plus-kern)))] + [else (error "bad module rename: ~e" a)]))] [(boolean? a) `(#%top-level-rename ,a)] [(symbol? a) '(#%mark-barrier)] [(box? a) - `(#%phase-shift ,(unbox a))] + (match (unbox a) + [`#(,amt ,src ,dest #f) + (make-phase-shift amt + (parse-module-path-index cp src) + (parse-module-path-index cp dest))] + [else (error 'parse "bad phase shift: ~e" a)])] [else (error 'decode-wraps "bad wrap element: ~e" a)]))) w))) @@ -544,6 +641,20 @@ (vector-set! (cport-symtab cp) pos v) (vector-set! (cport-decoded cp) pos #t)) +(define (parse-module-path-index cp s) + (cond + [(not s) #f] + [(module-path-index? s) + (hash-ref (cport-mpis cp) s + (lambda () + (let-values ([(name base) (module-path-index-split s)]) + (let ([v `(module-path-index-join + (quote ,name) + ,(parse-module-path-index cp base))]) + (hash-set! (cport-mpis cp) s v) + v))))] + [else `(quote ,s)])) + ;; ---------------------------------------- ;; Main parsing loop @@ -784,7 +895,7 @@ (define symtab (make-vector symtabsize (make-not-ready))) - (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash))) + (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) (when (not-ready? (vector-ref symtab i)) (set-cport-pos! cp (vector-ref so* (sub1 i))) From 8b1b6eec7fab62e97cb32239072c314c4a21b150 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 27 Oct 2008 19:00:13 +0000 Subject: [PATCH 077/466] jit tweaks svn: r12144 original commit: 00d2aabaf06b0fd75eee91f5abd06ebaef9175b2 --- collects/compiler/decompile.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 5f1248b43e..12075f4119 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -299,7 +299,7 @@ zero? negative? exact-nonnegative-integer? exact-positive-integer? car cdr caar cadr cdar cddr - mcar mcdr unbox syntax-e + mcar mcdr unbox vector-length syntax-e add1 sub1 - abs bitwise-not))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? From 25ac110c4f885c68f8d37a4a8c275dabfab77e85 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Oct 2008 01:40:51 +0000 Subject: [PATCH 078/466] split scribble/manual module into smaller modules svn: r12150 original commit: ea659ba286fc5c1fda44a89d10c137473e46e8da --- collects/compiler/zo-parse.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 29b7b76f5b..ce0578b3a2 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -544,7 +544,8 @@ (if kind 'marked 'normal) set-id (map (lambda (u) - (let ([just-phase? (number? (cddr u))]) + (let ([just-phase? (let ([v (cddr u)]) + (or (number? v) (not v)))]) (let-values ([(exns prefix) (if just-phase? (values null #f) From 0150fc24ed34d1f8fd0a91762f378766f4395698 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 30 Oct 2008 10:55:07 +0000 Subject: [PATCH 079/466] fix more bugs with lib paths in exe creation svn: r12175 original commit: 487df2362e2648289120340f11947aa52b8a3bfa --- collects/tests/mzscheme/embed-me1d.ss | 8 ++++++++ collects/tests/mzscheme/embed-me1e.ss | 8 ++++++++ collects/tests/mzscheme/embed.ss | 2 ++ 3 files changed, 18 insertions(+) create mode 100644 collects/tests/mzscheme/embed-me1d.ss create mode 100644 collects/tests/mzscheme/embed-me1e.ss diff --git a/collects/tests/mzscheme/embed-me1d.ss b/collects/tests/mzscheme/embed-me1d.ss new file mode 100644 index 0000000000..cc6b750193 --- /dev/null +++ b/collects/tests/mzscheme/embed-me1d.ss @@ -0,0 +1,8 @@ +#lang scheme/base + +(require scheme/runtime-path + (for-syntax scheme/base)) +(define-runtime-path file '(lib "file.gif" "icons")) +(with-output-to-file "stdout" + (lambda () (printf "This is 1d~n")) + #:exists 'append) diff --git a/collects/tests/mzscheme/embed-me1e.ss b/collects/tests/mzscheme/embed-me1e.ss new file mode 100644 index 0000000000..645df59905 --- /dev/null +++ b/collects/tests/mzscheme/embed-me1e.ss @@ -0,0 +1,8 @@ +#lang scheme/base + +(require scheme/runtime-path + (for-syntax scheme/base)) +(define-runtime-path file '(lib "html")) +(with-output-to-file "stdout" + (lambda () (printf "This is 1e~n")) + #:exists 'append) diff --git a/collects/tests/mzscheme/embed.ss b/collects/tests/mzscheme/embed.ss index cf4963ac63..e7aa33ba27 100644 --- a/collects/tests/mzscheme/embed.ss +++ b/collects/tests/mzscheme/embed.ss @@ -213,6 +213,8 @@ (one-mz-test "embed-me1.ss" "This is 1\n" #t) (one-mz-test "embed-me1b.ss" "This is 1b\n" #f) (one-mz-test "embed-me1c.ss" "This is 1c\n" #f) + (one-mz-test "embed-me1d.ss" "This is 1d\n" #f) + (one-mz-test "embed-me1e.ss" "This is 1e\n" #f) (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n" #t) ;; Try unicode expr and cmdline: From 57306506420aac5d539abad45b595903fb5c6877 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 6 Nov 2008 18:54:12 +0000 Subject: [PATCH 080/466] change mzc verbosity svn: r12333 original commit: f076494c48e80b384076017e4dc0add0f97ca7f9 --- collects/compiler/sig.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index 426dc6ee28..ed1350d5d6 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -9,7 +9,9 @@ ;; Compiler options (define-signature compiler:option^ - (verbose ; default = #f + (somewhat-verbose ; default = #f + verbose ; default = #f + setup-prefix ; string to embed in public names; ; used mainly for compiling extensions From c3ee691e9da083a08636b0495182a37ce2e64896 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 13 Nov 2008 16:42:15 +0000 Subject: [PATCH 081/466] improved JIT inlining of 'list' svn: r12428 original commit: bac4053c379eee9a19d9aa6ce4ce3e9528e06ca1 --- collects/compiler/decompile.ss | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 12075f4119..e541684f17 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -300,14 +300,17 @@ exact-positive-integer? car cdr caar cadr cdar cddr mcar mcdr unbox vector-length syntax-e - add1 sub1 - abs bitwise-not))] + add1 sub1 - abs bitwise-not + list vector box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref - set-mcar! set-mcdr! cons mcons))] - [(4) (memq (car a) '(vector-set! string-set! bytes-set!))] - [else #f])) + set-mcar! set-mcdr! cons mcons + list vector))] + [(4) (memq (car a) '(vector-set! string-set! bytes-set! + list vector))] + [else (memq (car a) '(list vector))])) (cons '#%in a) a)) From 66ad436925c25d0290414eee96cd6717f7f4160b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 14 Nov 2008 00:48:54 +0000 Subject: [PATCH 082/466] make the optimizer slightly smarter, so that it can see through more patterns of nested let and letrec procedure bindings svn: r12434 original commit: 59f3f19f84a2e0b0471e35834c3ec2764b913377 --- collects/compiler/decompile.ss | 4 ++-- collects/compiler/zo-parse.ss | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index e541684f17..70a64f71c1 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -40,7 +40,7 @@ ;; Main entry: (define (decompile top) (match top - [(struct compilation-top (_ prefix form)) + [(struct compilation-top (max-let-depth prefix form)) (let-values ([(globs defns) (decompile-prefix prefix)]) `(begin ,@defns @@ -88,7 +88,7 @@ (define (decompile-module mod-form stack) (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body)) + [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) (let-values ([(globs defns) (decompile-prefix prefix)] [(stack) (append '(#%modvars) stack)]) `(module ,name .... diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index ce0578b3a2..a19caea4ad 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -23,7 +23,7 @@ ;; In stxs of prefix: (define-form-struct stx (encoded)) ; todo: decode syntax objects -(define-form-struct mod (name self-modidx prefix provides requires body syntax-body)) +(define-form-struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) (define-form-struct lam (name flags num-params rest? closure-map max-let-depth body)) ; `lambda' (define-form-struct closure (code gen-id)) ; a static closure (nothing to close over) @@ -220,7 +220,8 @@ make-def-for-syntax make-def-syntaxes) ids expr prefix max-let-depth)])) - (vector->list syntax-body)))]))])) + (vector->list syntax-body)) + max-let-depth)]))])) (define (read-module-wrap v) v) From 2a6f851d433e5aa81bf49390669ace553ef0dfd5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:47:06 +0000 Subject: [PATCH 083/466] decompiler repairs svn: r12537 original commit: 1a4b3abba7cc0191ea431ef86a7bdd4911a0d41d --- collects/compiler/decompile.ss | 122 ++++++++++++++++++--------------- collects/compiler/zo-parse.ss | 17 +++-- 2 files changed, 75 insertions(+), 64 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 70a64f71c1..4fc5259255 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -28,12 +28,12 @@ (hash-set! table n (car b))))) table)) -(define (list-ref/protect l pos) +(define (list-ref/protect l pos who) (list-ref l pos) #; (if (pos . < . (length l)) (list-ref l pos) - `(OUT-OF-BOUNDS ,pos ,l))) + `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l))) ;; ---------------------------------------- @@ -44,7 +44,7 @@ (let-values ([(globs defns) (decompile-prefix prefix)]) `(begin ,@defns - ,(decompile-form form globs '(#%globals))))] + ,(decompile-form form globs '(#%globals) (make-hasheq))))] [else (error 'decompile "unrecognized: ~e" top)])) (define (decompile-prefix a-prefix) @@ -76,7 +76,7 @@ lift-ids) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,(stx-encoded stx)) + `(#%decode-syntax ,stx #;(stx-encoded stx)) #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -90,18 +90,19 @@ (match mod-form [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) (let-values ([(globs defns) (decompile-prefix prefix)] - [(stack) (append '(#%modvars) stack)]) + [(stack) (append '(#%modvars) stack)] + [(closed) (make-hasheq)]) `(module ,name .... ,@defns ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) syntax-body) ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) body)))] [else (error 'decompile-module "huh?: ~e" mod-form)])) -(define (decompile-form form globs stack) +(define (decompile-form form globs stack closed) (match form [(? mod?) (decompile-module form stack)] @@ -109,31 +110,31 @@ `(define-values ,(map (lambda (tl) (match tl [(struct toplevel (depth pos const? mutated?)) - (list-ref/protect globs pos)])) + (list-ref/protect globs pos 'def-vals)])) ids) - ,(decompile-expr rhs globs stack))] + ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-form rhs globs '(#%globals)))))] + ,(decompile-form rhs globs '(#%globals) closed))))] [(struct def-for-syntax (ids rhs prefix max-let-depth)) `(define-values-for-syntax ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-expr rhs globs '(#%globals)))))] + ,(decompile-expr rhs globs '(#%globals) closed))))] [(struct sequence (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [(struct splice (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [else - (decompile-expr form globs stack)])) + (decompile-expr form globs stack closed)])) (define (extract-name name) (if (symbol? name) @@ -168,22 +169,22 @@ (extract-ids! body ids)] [else #f])) -(define (decompile-expr expr globs stack) +(define (decompile-expr expr globs stack closed) (match expr [(struct toplevel (depth pos const? mutated?)) - (let ([id (list-ref/protect globs pos)]) + (let ([id (list-ref/protect globs pos 'toplevel)]) (if const? id `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) - (list-ref/protect globs (+ midpt pos))] + (list-ref/protect globs (+ midpt pos) 'topsyntax)] [(struct primitive (id)) (hash-ref primitive-table id)] [(struct assign (id rhs undef-ok?)) - `(set! ,(decompile-expr id globs stack) - ,(decompile-expr rhs globs stack))] + `(set! ,(decompile-expr id globs stack closed) + ,(decompile-expr rhs globs stack closed))] [(struct localref (unbox? offset clear?)) - (let ([id (list-ref/protect stack offset)]) + (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) id)]) @@ -191,17 +192,17 @@ `(#%sfs-clear ,e) e)))] [(? lam?) - `(lambda . ,(decompile-lam expr globs stack))] + `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) `(case-lambda ,@(map (lambda (lam) - (decompile-lam lam globs stack)) + (decompile-lam lam globs stack closed)) lams))] [(struct let-one (rhs body)) (let ([id (or (extract-id rhs) (gensym 'local))]) - `(let ([,id ,(decompile-expr rhs globs (cons id stack))]) - ,(decompile-expr body globs (cons id stack))))] + `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) + ,(decompile-expr body globs (cons id stack) closed)))] [(struct let-void (count boxes? body)) (let ([ids (make-vector count #f)]) (extract-ids! body ids) @@ -210,71 +211,76 @@ (or id (gensym 'localv)))]) `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) vars) - ,(decompile-expr body globs (append vars stack)))))] + ,(decompile-expr body globs (append vars stack) closed))))] [(struct let-rec (procs body)) `(begin (#%set!-rec-values ,(for/list ([p (in-list procs)] [i (in-naturals)]) - (list-ref/protect stack i)) + (list-ref/protect stack i 'let-rec)) ,@(map (lambda (proc) - (decompile-expr proc globs stack)) + (decompile-expr proc globs stack closed)) procs)) - ,(decompile-expr body globs stack))] + ,(decompile-expr body globs stack closed))] [(struct install-value (count pos boxes? rhs body)) `(begin (,(if boxes? '#%set-boxes! 'set!-values) ,(for/list ([i (in-range count)]) - (list-ref/protect stack (+ i pos))) - ,(decompile-expr rhs globs stack)) - ,(decompile-expr body globs stack))] + (list-ref/protect stack (+ i pos) 'install-value)) + ,(decompile-expr rhs globs stack closed)) + ,(decompile-expr body globs stack closed))] [(struct boxenv (pos body)) - (let ([id (list-ref/protect stack pos)]) + (let ([id (list-ref/protect stack pos 'boxenv)]) `(begin (set! ,id (#%box ,id)) - ,(decompile-expr body globs stack)))] + ,(decompile-expr body globs stack closed)))] [(struct branch (test then else)) - `(if ,(decompile-expr test globs stack) - ,(decompile-expr then globs stack) - ,(decompile-expr else globs stack))] + `(if ,(decompile-expr test globs stack closed) + ,(decompile-expr then globs stack closed) + ,(decompile-expr else globs stack closed))] [(struct application (rator rands)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) stack)]) (annotate-inline - `(,(decompile-expr rator globs stack) + `(,(decompile-expr rator globs stack closed) ,@(map (lambda (rand) - (decompile-expr rand globs stack)) + (decompile-expr rand globs stack closed)) rands))))] [(struct apply-values (proc args-expr)) - `(#%apply-values ,(decompile-expr proc globs stack) - ,(decompile-expr args-expr globs stack))] + `(#%apply-values ,(decompile-expr proc globs stack closed) + ,(decompile-expr args-expr globs stack closed))] [(struct sequence (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) `(begin0 ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct with-cont-mark (key val body)) `(with-continuation-mark - ,(decompile-expr key globs stack) - ,(decompile-expr val globs stack) - ,(decompile-expr body globs stack))] + ,(decompile-expr key globs stack closed) + ,(decompile-expr val globs stack closed) + ,(decompile-expr body globs stack closed))] [(struct closure (lam gen-id)) - `(#%closed ,gen-id ,(decompile-expr lam globs stack))] + (if (hash-ref closed gen-id #f) + gen-id + (begin + (hash-set! closed gen-id #t) + `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))] [(struct indirect (val)) (if (closure? val) - (closure-gen-id val) + (decompile-expr val globs stack closed) '???)] [else `(quote ,expr)])) -(define (decompile-lam expr globs stack) +(define (decompile-lam expr globs stack closed) (match expr - [(struct closure (lam gen-id)) (decompile-lam lam globs stack)] + [(struct indirect (val)) (decompile-lam val globs stack closed)] + [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] [(struct lam (name flags num-params rest? closure-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)]) (gensym (format "arg~a-" i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) - (list-ref/protect stack v)) + (list-ref/protect stack v 'lam)) (vector->list closure-map))]) `((,@vars . ,(if rest? (car rest-vars) @@ -285,8 +291,10 @@ ,@(if (null? captures) null `('(captures: ,@captures))) - ,(decompile-expr body globs (append captures - (append vars rest-vars)))))])) + ,(decompile-expr body globs + (append captures + (append vars rest-vars)) + closed)))])) (define (annotate-inline a) (if (and (symbol? (car a)) @@ -301,16 +309,16 @@ car cdr caar cadr cdar cddr mcar mcdr unbox vector-length syntax-e add1 sub1 - abs bitwise-not - list vector box))] + list list* vector vector-immutable box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons - list vector))] + list list* vector vector-immutable))] [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list vector))] - [else (memq (car a) '(list vector))])) + list list* vector vector-immutable))] + [else (memq (car a) '(list list* vector vector-immutable))])) (cons '#%in a) a)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index a19caea4ad..57472a6c38 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -661,7 +661,7 @@ ;; Main parsing loop (define (read-compact cp) - (let loop ([need-car 0] [proper #f] [last #f] [first #f]) + (let loop ([need-car 0] [proper #f]) (begin-with-definitions (define ch (cp-getc cp)) (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) @@ -707,7 +707,7 @@ (cons (read-compact cp) (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) - (loop l ppr last first)))] + (loop l ppr)))] [(let-one) (make-let-one (read-compact cp) (read-compact cp))] [(branch) @@ -747,8 +747,10 @@ (read-compact cp))]) (vector->immutable-vector (list->vector lst)))] [(list) (let* ([n (read-compact-number cp)]) - (for/list ([i (in-range n)]) - (read-compact cp)))] + (append + (for/list ([i (in-range n)]) + (read-compact cp)) + (read-compact cp)))] [(prefab) (let ([v (read-compact cp)]) (apply make-prefab-struct @@ -845,9 +847,8 @@ [(symbol? s) s] [(vector? s) (vector-ref s 0)] [else 'closure]))))]) - (vector-set! (cport-symtab cp) l cl) (set-indirect-v! ind cl) - cl))] + ind))] [(svector) (read-compact-svector cp (read-compact-number cp))] [(small-svector) @@ -858,7 +859,7 @@ [(and proper (= need-car 1)) (cons v null)] [else - (cons v (loop (sub1 need-car) proper last first))])))) + (cons v (loop (sub1 need-car) proper))])))) ;; path -> bytes ;; implementes read.c:read_compiled @@ -898,11 +899,13 @@ (define symtab (make-vector symtabsize (make-not-ready))) (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) + (for/list ([i (in-range 1 symtabsize)]) (when (not-ready? (vector-ref symtab i)) (set-cport-pos! cp (vector-ref so* (sub1 i))) (let ([v (read-compact cp)]) (vector-set! symtab i v)))) + (set-cport-pos! cp shared-size) (read-marshalled 'compilation-top-type cp))) From 34af15866c619a27a1ff0b86af4e66961d083ae1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 7 Dec 2008 19:07:47 +0000 Subject: [PATCH 084/466] fix decompiler for recent .zo change svn: r12722 original commit: d8c28545eab69d4441b3fe9b6d82cd73c0919536 --- collects/compiler/zo-parse.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 57472a6c38..5794a0d3bc 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -197,7 +197,9 @@ [`(,name ,self-modidx ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy ,prefix ,kernel-exclusion ,reprovide-kernel? - ,indirect-provides ,num-indirect-provides ,protects + ,indirect-provides ,num-indirect-provides + ,indirect-et-provides ,num-indirect-et-provides + ,protects ,et-protects ,provide-phase-count . ,rest) (let ([phase-data (take rest (* 8 provide-phase-count))]) (match (list-tail rest (* 8 provide-phase-count)) From 0e41ae2e49e2bf676c4dfcde405069dff4a1fedd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 13 Dec 2008 17:38:14 +0000 Subject: [PATCH 085/466] trim some fat from module-variable references svn: r12833 original commit: cf8b75939bb426327ffca2fba559a12ae5673810 --- collects/compiler/decompile.ss | 3 ++- collects/compiler/zo-parse.ss | 22 +++++++++++----------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 4fc5259255..99336c5e37 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -57,7 +57,8 @@ (values (append (map (lambda (tl) (match tl - [(? symbol?) '#%linkage] + [#f '#%linkage] + [(? symbol?) (string->symbol (format "_~a" tl))] [(struct global-bucket (name)) (string->symbol (format "_~a" name))] [(struct module-variable (modidx sym pos phase)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 5794a0d3bc..41366dafdb 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -85,15 +85,10 @@ (define (read-variable v) (if (symbol? v) (make-global-bucket v) - (let-values ([(phase modname varname) - (match v - [(list* phase modname varname) - (values phase modname varname)] - [(list* modname varname) - (values 0 modname varname)])]) - (if (and (zero? phase) (eq? modname '#%kernel)) - (error 'bucket "var ~a" varname) - (make-module-variable modname varname -1 phase))))) + (error "expected a symbol"))) + +(define (do-not-read-variable v) + (error "should not get here")) (define (read-compilation-top v) (match v @@ -198,6 +193,7 @@ ,rename ,max-let-depth ,dummy ,prefix ,kernel-exclusion ,reprovide-kernel? ,indirect-provides ,num-indirect-provides + ,indirect-syntax-provides ,num-indirect-syntax-provides ,indirect-et-provides ,num-indirect-et-provides ,protects ,et-protects ,provide-phase-count . ,rest) @@ -282,7 +278,7 @@ (cons 'with-cont-mark-type read-with-cont-mark) (cons 'quote-syntax-type read-topsyntax) (cons 'variable-type read-variable) - (cons 'module-variable-type read-variable) + (cons 'module-variable-type do-not-read-variable) (cons 'compilation-top-type read-compilation-top) (cons 'case-lambda-sequence-type read-case-lambda) (cons 'begin0-sequence-type read-sequence) @@ -719,7 +715,11 @@ (let ([mod (read-compact cp)] [var (read-compact cp)] [pos (read-compact-number cp)]) - (make-module-variable mod var pos 0))] + (let-values ([(mod-phase pos) + (if (= pos -2) + (values 1 (read-compact-number cp)) + (values 0 pos))]) + (make-module-variable mod var pos mod-phase)))] [(local-unbox) (let* ([p* (read-compact-number cp)] [p (if (< p* 0) From 8432051c18559cf0d418266827039dc8ad697750 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Dec 2008 17:16:39 +0000 Subject: [PATCH 086/466] fix ready-toplevel optimization svn: r12905 original commit: 064776348a4529b30f497376b98bd0ae95e45807 --- collects/compiler/decompile.ss | 4 ++-- collects/compiler/zo-parse.ss | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 99336c5e37..c78d310a40 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -172,9 +172,9 @@ (define (decompile-expr expr globs stack closed) (match expr - [(struct toplevel (depth pos const? mutated?)) + [(struct toplevel (depth pos const? ready?)) (let ([id (list-ref/protect globs pos 'toplevel)]) - (if const? + (if (or const? ready?) id `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 41366dafdb..00c1a5dbb2 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -37,7 +37,7 @@ (define-form-struct localref (unbox? offset clear?)) ; access local via stack -(define-form-struct toplevel (depth pos const? mutated?)) ; access binding via prefix array (which is on stack) +(define-form-struct toplevel (depth pos const? ready?)) ; access binding via prefix array (which is on stack) (define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack) (define-form-struct application (rator rands)) ; function call @@ -68,12 +68,12 @@ (define (read-toplevel v) (define SCHEME_TOPLEVEL_CONST #x01) - (define SCHEME_TOPLEVEL_MUTATED #x02) + (define SCHEME_TOPLEVEL_READY #x02) (match v [(cons depth (cons pos flags)) (make-toplevel depth pos (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) - (positive? (bitwise-and flags SCHEME_TOPLEVEL_MUTATED)))] + (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))] [(cons depth pos) (make-toplevel depth pos #f #f)])) From c53917fa4fadba14f6acd076b12cdf30655f90bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Dec 2008 18:57:13 +0000 Subject: [PATCH 087/466] document compiler/zo-parse and compiler/decompile svn: r12947 original commit: 7aec6b876181bea97b43f16fbe2c237f946d06b3 --- collects/compiler/decompile.ss | 10 ++-- collects/compiler/zo-parse.ss | 83 ++++++++++++++++++++-------------- 2 files changed, 53 insertions(+), 40 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index c78d310a40..cef5601613 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -23,7 +23,7 @@ (close-output-port out) in)))]) (let ([n (match v - [(struct compilation-top (_ prefix (struct primitive (n)))) n] + [(struct compilation-top (_ prefix (struct primval (n)))) n] [else #f])]) (hash-set! table n (car b))))) table)) @@ -77,7 +77,7 @@ lift-ids) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,stx #;(stx-encoded stx)) + `(#%decode-syntax ,(stx-encoded stx)) #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -126,7 +126,7 @@ `(let () ,@defns ,(decompile-expr rhs globs '(#%globals) closed))))] - [(struct sequence (forms)) + [(struct seq (forms)) `(begin ,@(map (lambda (form) (decompile-form form globs stack closed)) forms))] @@ -179,7 +179,7 @@ `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) (list-ref/protect globs (+ midpt pos) 'topsyntax)] - [(struct primitive (id)) + [(struct primval (id)) (hash-ref primitive-table id)] [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack closed) @@ -249,7 +249,7 @@ [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack closed) ,(decompile-expr args-expr globs stack closed))] - [(struct sequence (exprs)) + [(struct seq (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 00c1a5dbb2..6e4abbc12c 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -7,11 +7,18 @@ ;; ---------------------------------------- ;; Structures to represent bytecode -(define-syntax-rule (define-form-struct id (field-id ...)) +(define-syntax-rule (define-form-struct* id id+par (field-id ...)) (begin - (define-struct id (field-id ...) #:transparent) + (define-struct id+par (field-id ...) #:transparent) (provide (struct-out id)))) +(define-syntax define-form-struct + (syntax-rules () + [(_ (id sup) . rest) + (define-form-struct* id (id sup) . rest)] + [(_ id . rest) + (define-form-struct* id id . rest)])) + (define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this (define-form-struct prefix (num-lifts toplevels stxs)) ; sets up top-level and syntax-object array @@ -21,43 +28,46 @@ (define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id ;; In stxs of prefix: -(define-form-struct stx (encoded)) ; todo: decode syntax objects +(define-form-struct stx (encoded)) -(define-form-struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) +(define-form-struct form ()) +(define-form-struct (expr form) ()) -(define-form-struct lam (name flags num-params rest? closure-map max-let-depth body)) ; `lambda' -(define-form-struct closure (code gen-id)) ; a static closure (nothing to close over) -(define-form-struct case-lam (name clauses)) ; each clause is an lam +(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth)) -(define-form-struct let-one (rhs body)) ; pushes one value onto stack -(define-form-struct let-void (count boxes? body)) ; create new stack slots -(define-form-struct install-value (count pos boxes? rhs body)) ; set existing stack slot(s) -(define-form-struct let-rec (procs body)) ; put `letrec'-bound closures into existing stack slots -(define-form-struct boxenv (pos body)) ; box existing stack element +(define-form-struct (lam expr) (name flags num-params rest? closure-map max-let-depth body)) ; `lambda' +(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) +(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam -(define-form-struct localref (unbox? offset clear?)) ; access local via stack +(define-form-struct (let-one expr) (rhs body)) ; pushes one value onto stack +(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots +(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s) +(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots +(define-form-struct (boxenv expr) (pos body)) ; box existing stack element -(define-form-struct toplevel (depth pos const? ready?)) ; access binding via prefix array (which is on stack) -(define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack) +(define-form-struct (localref expr) (unbox? pos clear?)) ; access local via stack -(define-form-struct application (rator rands)) ; function call -(define-form-struct branch (test then else)) ; `if' -(define-form-struct with-cont-mark (key val body)) ; `with-continuation-mark' -(define-form-struct beg0 (seq)) ; `begin0' -(define-form-struct sequence (forms)) ; `begin' -(define-form-struct splice (forms)) ; top-level `begin' -(define-form-struct varref (toplevel)) ; `#%variable-reference' -(define-form-struct assign (id rhs undef-ok?)) ; top-level or module-level set! -(define-form-struct apply-values (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc) -(define-form-struct primitive (id)) ; direct preference to a kernel primitive +(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack) +(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack) + +(define-form-struct (application expr) (rator rands)) ; function call +(define-form-struct (branch expr) (test then else)) ; `if' +(define-form-struct (with-cont-mark expr) (key val body)) ; `with-continuation-mark' +(define-form-struct (beg0 expr) (seq)) ; `begin0' +(define-form-struct (seq form) (forms)) ; `begin' +(define-form-struct (splice form) (forms)) ; top-level `begin' +(define-form-struct (varref expr) (toplevel)) ; `#%variable-reference' +(define-form-struct (assign expr) (id rhs undef-ok?)) ; top-level or module-level set! +(define-form-struct (apply-values expr) (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (primval expr) (id)) ; direct preference to a kernel primitive ;; Definitions (top level or within module): -(define-form-struct def-values (ids rhs)) -(define-form-struct def-syntaxes (ids rhs prefix max-let-depth)) -(define-form-struct def-for-syntax (ids rhs prefix max-let-depth)) +(define-form-struct (def-values form) (ids rhs)) +(define-form-struct (def-syntaxes form) (ids rhs prefix max-let-depth)) +(define-form-struct (def-for-syntax form) (ids rhs prefix max-let-depth)) ;; Top-level `require' -(define-form-struct req (reqs dummy)) +(define-form-struct (req form) (reqs dummy)) ;; A static closure can refer directly to itself, creating a cycle (define-struct indirect ([v #:mutable]) #:prefab) @@ -145,7 +155,7 @@ (make-with-cont-mark key val body)])) (define (read-sequence v) - (make-sequence v)) + (make-seq v)) (define (read-define-values v) (make-def-values @@ -173,7 +183,7 @@ (define (read-begin0 v) (match v - [(struct sequence (exprs)) + [(struct seq (exprs)) (make-beg0 exprs)])) (define (read-boxenv v) @@ -429,9 +439,12 @@ ;; Synatx unmarshaling (define-form-struct wrapped (datum wraps certs)) -(define-form-struct lexical-rename (alist)) -(define-form-struct phase-shift (amt src dest)) -(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) + +(define-form-struct wrap ()) +(define-form-struct (lexical-rename wrap) (alist)) +(define-form-struct (phase-shift wrap) (amt src dest)) +(define-form-struct (module-rename wrap) (phase kind set-id unmarshals renames mark-renames plus-kern?)) + (define-form-struct all-from-module (path phase src-phase exceptions prefix)) (define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id)) @@ -696,7 +709,7 @@ [read-accept-quasiquote #t]) (read (open-input-bytes s))))] [(reference) - (make-primitive (read-compact-number cp))] + (make-primval (read-compact-number cp))] [(small-list small-proper-list) (let* ([l (- ch cpt-start)] [ppr (eq? cpt-tag 'small-proper-list)]) From a724fe6a0091e5b13205134e16f60c84a99d87de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Mar 2009 00:48:08 +0000 Subject: [PATCH 088/466] rename write-bytecode to zo-marshal svn: r13974 original commit: 25e7978999f71d511883507065455eb101b7b6dc --- collects/compiler/write-bytecode.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/write-bytecode.ss b/collects/compiler/write-bytecode.ss index a37b768341..327c167163 100644 --- a/collects/compiler/write-bytecode.ss +++ b/collects/compiler/write-bytecode.ss @@ -2,12 +2,12 @@ (require compiler/zo-parse scheme/match) -(provide write-bytecode) +(provide zo-marshal) ;; Doesn't write as compactly as MzScheme, since list and pair sequences ;; are not compated, and symbols are not written in short form -(define (write-bytecode top) +(define (zo-marshal top) (match top [(struct compilation-top (max-let-depth prefix form)) (let ([encountered (make-hasheq)] From 0d40ac7b7fd72b52df3b5ff3303cb0c8ca97066d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Mar 2009 02:23:19 +0000 Subject: [PATCH 089/466] partially working compiler/zo-marshal svn: r13976 original commit: 5a8bd8b724ac0910051d0202eb29dc7486255c57 --- collects/compiler/zo-marshal.ss | 683 ++++++++++++++++++++++++++++++++ collects/compiler/zo-parse.ss | 25 +- 2 files changed, 696 insertions(+), 12 deletions(-) create mode 100644 collects/compiler/zo-marshal.ss diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss new file mode 100644 index 0000000000..8091e93e1b --- /dev/null +++ b/collects/compiler/zo-marshal.ss @@ -0,0 +1,683 @@ +#lang scheme/base +(require compiler/zo-parse + scheme/match) + +(provide zo-marshal) + +;; Doesn't write as compactly as MzScheme, since list and pair sequences +;; are not compated, and symbols are not written in short form + +(define (zo-marshal top) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (let ([encountered (make-hasheq)] + [shared (make-hasheq)]) + (let ([visit (lambda (v) + (if (hash-ref shared v #f) + #f + (if (hash-ref encountered v #f) + (begin + (hash-set! shared v (add1 (hash-count shared))) + #f) + (begin + (hash-set! encountered v #t) + #t))))]) + (traverse-prefix prefix visit) + (traverse-form form visit)) + (let* ([s (open-output-bytes)] + [out (make-out s (lambda (v) (hash-ref shared v #f)))] + [offsets + (map (lambda (v) + (let ([v (cdr v)]) + (begin0 + (file-position s) + (out-anything v (make-out + s + (let ([skip? #t]) + (lambda (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (hash-ref shared v2 #f))))))))) + (sort (hash-map shared (lambda (k v) (cons v k))) + < + #:key car))] + [post-shared (file-position s)] + [all-short? (post-shared . < . #xFFFF)]) + (out-data (list* max-let-depth prefix (protect-quote form)) out) + (let ([res (get-output-bytes s)]) + (bytes-append #"#~" + (bytes (string-length (version))) + (string->bytes/latin-1 (version)) + (int->bytes (add1 (hash-count shared))) + (bytes (if all-short? + 1 + 0)) + (apply + bytes-append + (map (lambda (o) + (integer->integer-bytes o + (if all-short? 2 4) + #f + #f)) + offsets)) + (int->bytes post-shared) + (int->bytes (bytes-length res)) + res))))])) + +;; ---------------------------------------- + +(define (traverse-prefix a-prefix visit) + (match a-prefix + [(struct prefix (num-lifts toplevels stxs)) + (for-each (lambda (stx) (traverse-toplevel stx visit)) stxs) + (for-each (lambda (stx) (traverse-stx stx visit)) stxs)])) + +(define (traverse-module mod-form visit) + (match mod-form + [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) + (error "cannot handle modules, yet") + (traverse-data name visit) + (traverse-data self-modidx visit) + (traverse-prefix prefix visit) + (for-each (lambda (f) (traverse-form f prefix)) body) + (for-each (lambda (f) (traverse-form f prefix)) syntax-body)])) + +(define (traverse-toplevel tl visit) + (match tl + [#f (void)] + [(? symbol?) (visit tl)] + [(struct global-bucket (name)) + (void)] + [(struct module-variable (modidx sym pos phase)) + (visit tl) + (let-values ([(p b) (module-path-index-split modidx)]) + (if (symbol? p) + (traverse-data p visit) + (traverse-data modidx visit))) + (traverse-data sym visit)])) + +(define (traverse-stx tl visit) + (error "cannot handle syntax objects, yet")) + +(define (traverse-form form visit) + (match form + [(? mod?) + (traverse-module form visit)] + [(struct def-values (ids rhs)) + (traverse-expr rhs visit)] + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (traverse-prefix prefix visit) + (traverse-expr rhs visit)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (traverse-prefix prefix visit) + (traverse-expr rhs visit)] + [(struct seq (forms)) + (for-each (lambda (f) (traverse-form f visit)) forms)] + [(struct splice (forms)) + (for-each (lambda (f) (traverse-form f visit)) forms)] + [else + (traverse-expr form visit)])) + +(define (traverse-expr expr visit) + (match expr + [(struct toplevel (depth pos const? ready?)) + (void)] + [(struct topsyntax (depth pos midpt)) + (void)] + [(struct primval (id)) + (void)] + [(struct assign (id rhs undef-ok?)) + (traverse-expr rhs)] + [(struct localref (unbox? offset clear? other-clears?)) + (void)] + [(? lam?) + (traverse-lam expr visit)] + [(struct case-lam (name lams)) + (traverse-data name visit) + (for-each (lambda (lam) (traverse-lam expr visit)) lams)] + [(struct let-one (rhs body)) + (traverse-expr rhs visit) + (traverse-expr body visit)] + [(struct let-void (count boxes? body)) + (traverse-expr body visit)] + [(struct let-rec (procs body)) + (for-each (lambda (lam) (traverse-lam lam visit)) procs) + (traverse-expr body visit)] + [(struct install-value (count pos boxes? rhs body)) + (traverse-expr rhs visit) + (traverse-expr body visit)] + [(struct boxenv (pos body)) + (traverse-expr body visit)] + [(struct branch (test then else)) + (traverse-expr test visit) + (traverse-expr then visit) + (traverse-expr else visit)] + [(struct application (rator rands)) + (traverse-expr rator visit) + (for-each (lambda (rand) (traverse-expr rand visit)) rands)] + [(struct apply-values (proc args-expr)) + (traverse-expr proc visit) + (traverse-expr args-expr visit)] + [(struct seq (exprs)) + (for-each (lambda (expr) (traverse-expr expr visit)) exprs)] + [(struct beg0 (exprs)) + (for-each (lambda (expr) (traverse-expr expr visit)) exprs)] + [(struct with-cont-mark (key val body)) + (traverse-expr key visit) + (traverse-expr val visit) + (traverse-expr body visit)] + [(struct closure (lam gen-id)) + (traverse-lam expr visit)] + [(struct indirect (val)) + (traverse-expr val visit)] + [else (traverse-data expr visit)])) + +(define (traverse-data expr visit) + (cond + [(or (symbol? expr) + (keyword? expr) + (string? expr) + (bytes? expr) + (path? expr) + (module-path-index? expr)) + (visit expr)] + [(pair? expr) + (traverse-data (car expr) visit) + (traverse-data (cdr expr) visit)] + [else (void)])) + +(define (traverse-lam expr visit) + (match expr + [(struct indirect (val)) (traverse-lam expr visit)] + [(struct closure (lam gen-id)) + (when (visit expr) + (traverse-lam expr visit))] + [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) + (traverse-data name visit) + (traverse-expr body visit)])) + +;; ---------------------------------------- + +(define toplevel-type-num 0) +(define syntax-type-num 3) +(define sequence-type-num 7) +(define unclosed-procedure-type-num 9) +(define let-value-type-num 10) +(define let-void-type-num 11) +(define letrec-type-num 12) +(define wcm-type-num 14) +(define quote-syntax-type-num 15) +(define variable-type-num 24) +(define top-type-num 87) +(define case-lambda-sequence-type-num 96) +(define prefix-type-num 103) + +(define-syntax define-enum + (syntax-rules () + [(_ n) (begin)] + [(_ n id . rest) + (begin + (define id n) + (define-enum (add1 n) . rest))])) + +(define-enum + 0 + CPT_ESCAPE + CPT_SYMBOL + CPT_SYMREF + CPT_WEIRD_SYMBOL + CPT_KEYWORD + CPT_BYTE_STRING + CPT_CHAR_STRING + CPT_CHAR + CPT_INT + CPT_NULL + CPT_TRUE + CPT_FALSE + CPT_VOID + CPT_BOX + CPT_PAIR + CPT_LIST + CPT_VECTOR + CPT_HASH_TABLE + CPT_STX + CPT_GSTX + CPT_MARSHALLED + CPT_QUOTE + CPT_REFERENCE + CPT_LOCAL + CPT_LOCAL_UNBOX + CPT_SVECTOR + CPT_APPLICATION + CPT_LET_ONE + CPT_BRANCH + CPT_MODULE_INDEX + CPT_MODULE_VAR + CPT_PATH + CPT_CLOSURE + CPT_DELAY_REF + CPT_PREFAB) + +(define-enum + 0 + DEFINE_VALUES_EXPD + DEFINE_SYNTAX_EXPD + SET_EXPD + CASE_LAMBDA_EXPD + BEGIN0_EXPD + BOXENV_EXPD + MODULE_EXPD + REQUIRE_EXPD + DEFINE_FOR_SYNTAX_EXPD + REF_EXPD + APPVALS_EXPD + SPLICE_EXPD) + +(define CPT_SMALL_LOCAL_START 192) +(define CPT_SMALL_LOCAL_END 207) +(define CPT_SMALL_LOCAL_UNBOX_START 207) +(define CPT_SMALL_LOCAL_UNBOX_END 222) + +(define CPT_SMALL_APPLICATION_START 247) +(define CPT_SMALL_APPLICATION_END 255) + +(define CLOS_HAS_REST 1) +(define CLOS_HAS_REF_ARGS 2) +(define CLOS_PRESERVES_MARKS 4) +(define CLOS_IS_METHOD 16) +(define CLOS_SINGLE_RESULT 32) + +(define BITS_PER_MZSHORT 32) + +(define *dummy* #f) + +(define (int->bytes x) + (integer->integer-bytes x + 4 + #f + #f)) + +(define-struct case-seq (name lams)) + +(define-struct out (s shared-index)) + +(define (out-shared v out k) + (let ([v ((out-shared-index out) v)]) + (if v + (begin + (out-byte CPT_SYMREF out) + (out-number v out)) + (k)))) + +(define (out-byte v out) + (write-byte v (out-s out))) + +(define (out-bytes b out) + (write-bytes b (out-s out))) + +(define (out-number n out) + (cond + [(n . < . 0) + (if (n . > . -32) + (out-byte (bitwise-ior #xC0 (- n)) out) + (begin + (out-byte #xE0 out) + (out-bytes (int->bytes (- n)) out)))] + [(n . < . 128) + (out-byte n out)] + [(n . < . #x4000) + (out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out) + (out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)] + [else + (out-bytes #xF0 out) + (out-bytes (int->bytes n) out)])) + +(define (out-syntax key val out) + (out-marshaled syntax-type-num (list* key val) out)) + +(define (out-marshaled type-num val out) + (out-byte CPT_MARSHALLED out) + (out-number type-num out) + (out-data val out)) + +(define (out-anything v out) + (cond + [(module-variable? v) + (out-toplevel v out)] + [(closure? v) + (out-expr v out)] + [else + (out-data v out)])) + +(define (out-prefix a-prefix out) + (match a-prefix + [(struct prefix (num-lifts toplevels stxs)) + (out-marshaled + prefix-type-num + (cons num-lifts + (cons (list->vector toplevels) + (list->vector stxs))) + out)])) + +(define (out-module mod-form out) + (match mod-form + [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) + (error "cannot write modules, yet")])) + +(define (out-toplevel tl out) + (match tl + [#f (out-data tl out)] + [(? symbol?) (out-data tl out)] + [(struct global-bucket (name)) + (out-marshaled variable-type-num name out)] + [(struct module-variable (modidx sym pos phase)) + (out-shared + tl + out + (lambda () + (out-byte CPT_MODULE_VAR out) + (let-values ([(p b) (module-path-index-split modidx)]) + (if (symbol? p) + (out-data p out) + (out-data modidx out))) + (out-data sym out) + (unless (zero? phase) + (out-number -2 out)) + (out-number pos out)))])) + +(define (out-stx tl out) + (error "cannot handle syntax objects, yet")) + +(define (out-form form out) + (match form + [(? mod?) + (out-module form out)] + [(struct def-values (ids rhs)) + (out-syntax DEFINE_VALUES_EXPD + (list->vector (cons rhs ids)) + out)] + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_SYNTAX_EXPD + (list->vector (list* rhs + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_FOR_SYNTAX_EXPD + (list->vector (list* rhs + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct seq (forms)) + (out-marshaled sequence-type-num (map protect-quote forms) out)] + [(struct splice (forms)) + (out-syntax SPLICE_EXPD (make-seq forms) out)] + [else + (out-expr form out)])) + +(define (out-expr expr out) + (match expr + [(struct toplevel (depth pos const? ready?)) + (out-marshaled toplevel-type-num + (if (or const? ready?) + (cons pos + (bitwise-ior + (if const? #x1 0) + (if ready? #x2 0))) + pos) + out)] + [(struct topsyntax (depth pos midpt)) + (out-marshaled quote-syntax-type-num + (cons depth + (cons pos midpt)) + out)] + [(struct primval (id)) + (out-byte CPT_REFERENCE out) + (out-number id out)] + [(struct assign (id rhs undef-ok?)) + (out-syntax SET_EXPD + (cons undef-ok? (cons id rhs)) + out)] + [(struct localref (unbox? offset clear? other-clears?)) + (if (and (not clear?) (not other-clears?) + (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) + (out-byte (+ (if unbox? + CPT_SMALL_LOCAL_UNBOX_START + CPT_SMALL_LOCAL_START) + offset) + out) + (begin + (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) + (if (not (or clear? other-clears?)) + (out-number offset out) + (begin + (out-number (- (add1 offset)) out) + (out-number (+ (if clear? #x1 0) + (if other-clears? #x2 0)) + out)))))] + [(? lam?) + (out-lam expr out)] + [(struct case-lam (name lams)) + (out-syntax CASE_LAMBDA_EXPD + (make-case-seq name lams))] + [(struct case-seq (name lams)) + (out-marshaled case-lambda-sequence-type-num + (cons (or name null) + lams) + out)] + [(struct let-one (rhs body)) + (out-byte CPT_LET_ONE out) + (out-expr (protect-quote rhs) out) + (out-expr (protect-quote body) out)] + [(struct let-void (count boxes? body)) + (out-marshaled let-void-type-num + (list* + count + boxes? + (protect-quote body)) + out)] + [(struct let-rec (procs body)) + (out-marshaled letrec-type-num + (list* + (length procs) + (protect-quote body) + procs) + out)] + [(struct install-value (count pos boxes? rhs body)) + (out-marshaled let-value-type-num + (list* + count + pos + boxes? + (protect-quote rhs) + (protect-quote body)) + out)] + [(struct boxenv (pos body)) + (out-syntax BOXENV_EXPD + (cons + pos + (protect-quote body)) + out)] + [(struct branch (test then else)) + (out-byte CPT_BRANCH out) + (out-expr (protect-quote test) out) + (out-expr (protect-quote then) out) + (out-expr (protect-quote else) out)] + [(struct application (rator rands)) + (if ((length rands) . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) + (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) + (begin + (out-byte CPT_APPLICATION out) + (out-number (length rands) out))) + (for-each (lambda (e) (out-expr (protect-quote e) out)) + (cons rator rands))] + [(struct apply-values (proc args-expr)) + (out-syntax APPVALS_EXPD + (cons (protect-quote proc) + (protect-quote args-expr)) + out)] + [(struct seq (exprs)) + (out-form expr out)] + [(struct beg0 (exprs)) + (out-syntax BEGIN0_EXPD + (make-seq exprs) + out)] + [(struct with-cont-mark (key val body)) + (out-marshaled wcm-type-num + (list* + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] + [(struct closure (lam gen-id)) + (out-lam expr out)] + [(struct indirect (val)) + (out-expr val out)] + [else (out-value expr out)])) + +(define (out-lam expr out) + (match expr + [(struct indirect (val)) (out-lam expr out)] + [(struct closure (lam gen-id)) + (out-shared + expr + out + (lambda () + (out-lam expr out)))] + [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) + (let* ([l (protect-quote body)] + [any-refs? (ormap (lambda (t) (eq? t 'ref)) param-types)] + [l (cons (make-svector (if any-refs? + (list->vector + (append + (vector->list closure-map) + (let ([v (make-vector (ceiling (/ num-params BITS_PER_MZSHORT)))]) + (for ([t (in-list param-types)] + [i (in-naturals)]) + (when (eq? t 'ref) + (let ([pos (quotient i BITS_PER_MZSHORT)]) + (vector-set! v pos + (bitwise-ior (vector-ref v pos) + (arithmetic-shift 1 (modulo i BITS_PER_MZSHORT))))))) + (vector->list v)))) + closure-map)) + l)] + [l (if any-refs? + (cons (vector-length closure-map) l) + l)]) + (out-marshaled unclosed-procedure-type-num + (list* + (+ (if rest? CLOS_HAS_REST 0) + (if any-refs? CLOS_HAS_REF_ARGS 0) + (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) + (if (memq 'is-method flags) CLOS_IS_METHOD 0) + (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) + ((if rest? add1 0) num-params) + max-let-depth + name + l) + out))])) + +(define (out-as-bytes expr ->bytes CPT out) + (out-shared expr out (lambda () + (let ([s (->bytes expr)]) + (out-byte CPT out) + (out-number (bytes-length s) out) + (out-bytes s out))))) + +(define (out-data expr out) + (cond + [(prefix? expr) (out-prefix expr out)] + [else (out-form expr out)])) + +(define (out-value expr out) + (cond + [(symbol? expr) + (out-as-bytes expr + (compose string->bytes/utf-8 symbol->string) + CPT_SYMBOL + out)] + [(keyword? expr) + (out-as-bytes expr + (compose string->bytes/utf-8 keyword->string) + CPT_KEYWORD + out)] + [(string? expr) + (out-as-bytes expr + string->bytes/utf-8 + CPT_CHAR_STRING + out)] + [(bytes? expr) + (out-as-bytes expr + values + CPT_BYTE_STRING + out)] + [(path? expr) + (out-as-bytes expr + path->bytes + CPT_PATH + out)] + [(char? expr) + (out-byte CPT_CHAR out) + (out-number (char->integer expr) out)] + [(and (exact-integer? expr) + (and (expr . >= . -1073741824) (expr . <= . 1073741823))) + (out-byte CPT_INT out) + (out-number expr out)] + [(null? expr) + (out-byte CPT_NULL out)] + [(eq? expr #t) + (out-byte CPT_TRUE out)] + [(eq? expr #f) + (out-byte CPT_FALSE out)] + [(void? expr) + (out-byte CPT_VOID out)] + [(box? expr) + (out-byte CPT_BOX out) + (out-data (unbox expr) out)] + [(pair? expr) + (out-byte CPT_LIST out) + (out-number 1 out) + (out-data (car expr) out) + (out-data (cdr expr) out)] + [(vector? expr) + (out-byte CPT_VECTOR out) + (out-number (vector-length expr) out) + (for ([v (in-vector expr)]) + (out-data v out))] + [(hash? expr) + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? expr) 2] + [(hash-eq? expr) 0] + [else 1])) + (for ([(k v) (in-hash expr)]) + (out-data k out) + (out-data v out))] + [(svector? expr) + (out-byte CPT_SVECTOR out) + (out-number (vector-length (svector-vec expr)) out) + (for ([n (in-vector (svector-vec expr))]) + (out-number n out))] + [else + (out-byte CPT_QUOTE out) + (let ([s (open-output-bytes)]) + (write (if (quoted? expr) (quoted-v expr) expr) s) + (out-bytes (get-output-bytes s) out))])) + +(define-struct quoted (v)) +(define (protect-quote v) + (if (or (list? v) (vector? v) (box? v) (hash? v)) + (make-quoted v) + v)) + +(define-struct svector (vec)) + +;; ---------------------------------------- + diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 73d9d2de60..f03d22ee85 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -127,20 +127,21 @@ (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (values (vector-length v) v rest) (values v (car rest) (cdr rest)))] - [(arg-types) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - (for/list ([i (in-range num-params)]) 'val) - (for/list ([i (in-range num-params)]) - (if (bitwise-bit-set? - (vector-ref closed-over - (+ closure-size (quotient i BITS_PER_MZSHORT))) - (remainder i BITS_PER_MZSHORT)) - 'ref - 'val)))]) + [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + (for/list ([i (in-range num-params)]) 'val) + (for/list ([i (in-range num-params)]) + (if (bitwise-bit-set? + (vector-ref closed-over + (+ closure-size (quotient i BITS_PER_MZSHORT))) + (remainder i BITS_PER_MZSHORT)) + 'ref + 'val))))]) (make-lam name (append - (if (bitwise-and flags flags CLOS_PRESERVES_MARKS) '(preserves-marks) null) - (if (bitwise-and flags flags CLOS_IS_METHOD) '(is-method) null) - (if (bitwise-and flags flags CLOS_SINGLE_RESULT) '(single-result) null)) + (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) + (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) + (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result))) ((if rest? sub1 values) num-params) arg-types rest? From cde9437405c6887af7bf9e15793ba756e66f7e90 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Mar 2009 15:22:33 +0000 Subject: [PATCH 090/466] zo-marshal bug fixes and start at test suite svn: r13979 original commit: f1e646c8f9eee5eddab32da8d46b452f22a2196c --- collects/compiler/write-bytecode.ss | 679 ---------------------------- collects/compiler/zo-marshal.ss | 2 +- 2 files changed, 1 insertion(+), 680 deletions(-) delete mode 100644 collects/compiler/write-bytecode.ss diff --git a/collects/compiler/write-bytecode.ss b/collects/compiler/write-bytecode.ss deleted file mode 100644 index 327c167163..0000000000 --- a/collects/compiler/write-bytecode.ss +++ /dev/null @@ -1,679 +0,0 @@ -#lang scheme/base -(require compiler/zo-parse - scheme/match) - -(provide zo-marshal) - -;; Doesn't write as compactly as MzScheme, since list and pair sequences -;; are not compated, and symbols are not written in short form - -(define (zo-marshal top) - (match top - [(struct compilation-top (max-let-depth prefix form)) - (let ([encountered (make-hasheq)] - [shared (make-hasheq)]) - (let ([visit (lambda (v) - (if (hash-ref shared v) - #f - (if (hash-ref encountered v #f) - (begin - (hash-set! shared v (hash-count shared)) - #f) - (begin - (hash-set! encountered v #t) - #t))))]) - (traverse-prefix prefix visit) - (traverse-form form visit)) - (let* ([s (open-output-bytes)] - [out (make-out s (lambda (v) (hash-ref shared v #f)))] - [offsets - (map (lambda (v) - (begin0 - (file-position s) - (out-anything v (make-out - s - (let ([skip? #f]) - (lambda (v2) - (if (and (not skip?) (eq? v v2)) - (begin - (set! skip? #t) - #f) - (hash-ref shared v2 #f)))))))) - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car))] - [post-shared (file-position s)] - [all-short? (post-shared . < . #xFFFF)]) - (out-data (list* max-let-depth prefix (protect-quote form)) out) - (let ([res (get-output-bytes s)]) - (bytes-append #"#~" - (bytes (string-length (version))) - (string->bytes/latin-1 (version)) - (int->bytes (add1 (hash-count shared))) - (bytes (if all-short? - 1 - 0)) - (apply - bytes-append - (map (lambda (o) - (integer->integer-bytes o - (if all-short? 2 4) - #f - #f)) - offsets)) - (int->bytes post-shared) - (int->bytes (bytes-length res)) - res))))])) - -;; ---------------------------------------- - -(define (traverse-prefix a-prefix visit) - (match a-prefix - [(struct prefix (num-lifts toplevels stxs)) - (for-each (lambda (stx) (traverse-toplevel stx visit)) stxs) - (for-each (lambda (stx) (traverse-stx stx visit)) stxs)])) - -(define (traverse-module mod-form visit) - (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) - (error "cannot handle modules, yet") - (traverse-data name visit) - (traverse-data self-modidx visit) - (traverse-prefix prefix visit) - (for-each (lambda (f) (traverse-form f prefix)) body) - (for-each (lambda (f) (traverse-form f prefix)) syntax-body)])) - -(define (traverse-toplevel tl visit) - (match tl - [#f (void)] - [(? symbol?) (visit tl)] - [(struct global-bucket (name)) - (void)] - [(struct module-variable (modidx sym pos phase)) - (visit tl) - (let-values ([(p b) (module-path-index-split modidx)]) - (if (symbol? p) - (traverse-data p visit) - (traverse-data modidx visit))) - (traverse-data sym visit)])) - -(define (traverse-stx tl visit) - (error "cannot handle syntax objects, yet")) - -(define (traverse-form form visit) - (match form - [(? mod?) - (traverse-module form visit)] - [(struct def-values (ids rhs)) - (traverse-expr rhs visit)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (traverse-prefix prefix visit) - (traverse-expr rhs visit)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (traverse-prefix prefix visit) - (traverse-expr rhs visit)] - [(struct seq (forms)) - (for-each (lambda (f) (traverse-form f visit)) forms)] - [(struct splice (forms)) - (for-each (lambda (f) (traverse-form f visit)) forms)] - [else - (traverse-expr form visit)])) - -(define (traverse-expr expr visit) - (match expr - [(struct toplevel (depth pos const? ready?)) - (void)] - [(struct topsyntax (depth pos midpt)) - (void)] - [(struct primval (id)) - (void)] - [(struct assign (id rhs undef-ok?)) - (traverse-expr rhs)] - [(struct localref (unbox? offset clear? other-clears?)) - (void)] - [(? lam?) - (traverse-lam expr visit)] - [(struct case-lam (name lams)) - (traverse-data name visit) - (for-each (lambda (lam) (traverse-lam expr visit)) lams)] - [(struct let-one (rhs body)) - (traverse-expr rhs visit) - (traverse-expr body visit)] - [(struct let-void (count boxes? body)) - (traverse-expr body visit)] - [(struct let-rec (procs body)) - (for-each (lambda (lam) (traverse-lam lam visit)) procs) - (traverse-expr body visit)] - [(struct install-value (count pos boxes? rhs body)) - (traverse-expr rhs visit) - (traverse-expr body visit)] - [(struct boxenv (pos body)) - (traverse-expr body visit)] - [(struct branch (test then else)) - (traverse-expr test visit) - (traverse-expr then visit) - (traverse-expr else visit)] - [(struct application (rator rands)) - (traverse-expr rator visit) - (for-each (lambda (rand) (traverse-expr rand visit)) rands)] - [(struct apply-values (proc args-expr)) - (traverse-expr proc visit) - (traverse-expr args-expr visit)] - [(struct seq (exprs)) - (for-each (lambda (expr) (traverse-expr expr visit)) exprs)] - [(struct beg0 (exprs)) - (for-each (lambda (expr) (traverse-expr expr visit)) exprs)] - [(struct with-cont-mark (key val body)) - (traverse-expr key visit) - (traverse-expr val visit) - (traverse-expr body visit)] - [(struct closure (lam gen-id)) - (traverse-lam expr visit)] - [(struct indirect (val)) - (traverse-expr val visit)] - [else (traverse-data expr visit)])) - -(define (traverse-data expr visit) - (cond - [(or (symbol? expr) - (keyword? expr) - (string? expr) - (bytes? expr) - (path? expr) - (module-path-index? expr)) - (visit expr)] - [(pair? expr) - (traverse-data (car expr) visit) - (traverse-data (cdr expr) visit)] - [else (void)])) - -(define (traverse-lam expr visit) - (match expr - [(struct indirect (val)) (traverse-lam expr visit)] - [(struct closure (lam gen-id)) - (when (visit expr) - (traverse-lam expr visit))] - [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) - (traverse-data name visit) - (traverse-expr body visit)])) - -;; ---------------------------------------- - -(define toplevel-type-num 0) -(define syntax-type-num 3) -(define sequence-type-num 7) -(define unclosed-procedure-type-num 9) -(define let-value-type-num 10) -(define let-void-type-num 11) -(define letrec-type-num 12) -(define wcm-type-num 14) -(define quote-syntax-type-num 15) -(define variable-type-num 24) -(define top-type-num 87) -(define case-lambda-sequence-type-num 96) -(define prefix-type-num 103) - -(define-syntax define-enum - (syntax-rules () - [(_ n) (begin)] - [(_ n id . rest) - (begin - (define id n) - (define-enum (add1 n) . rest))])) - -(define-enum - 0 - CPT_ESCAPE - CPT_SYMBOL - CPT_SYMREF - CPT_WEIRD_SYMBOL - CPT_KEYWORD - CPT_BYTE_STRING - CPT_CHAR_STRING - CPT_CHAR - CPT_INT - CPT_NULL - CPT_TRUE - CPT_FALSE - CPT_VOID - CPT_BOX - CPT_PAIR - CPT_LIST - CPT_VECTOR - CPT_HASH_TABLE - CPT_STX - CPT_GSTX - CPT_MARSHALLED - CPT_QUOTE - CPT_REFERENCE - CPT_LOCAL - CPT_LOCAL_UNBOX - CPT_SVECTOR - CPT_APPLICATION - CPT_LET_ONE - CPT_BRANCH - CPT_MODULE_INDEX - CPT_MODULE_VAR - CPT_PATH - CPT_CLOSURE - CPT_DELAY_REF - CPT_PREFAB) - -(define-enum - 0 - DEFINE_VALUES_EXPD - DEFINE_SYNTAX_EXPD - SET_EXPD - CASE_LAMBDA_EXPD - BEGIN0_EXPD - BOXENV_EXPD - MODULE_EXPD - REQUIRE_EXPD - DEFINE_FOR_SYNTAX_EXPD - REF_EXPD - APPVALS_EXPD - SPLICE_EXPD) - -(define CPT_SMALL_LOCAL_START 192) -(define CPT_SMALL_LOCAL_END 207) -(define CPT_SMALL_LOCAL_UNBOX_START 207) -(define CPT_SMALL_LOCAL_UNBOX_END 222) - -(define CPT_SMALL_APPLICATION_START 247) -(define CPT_SMALL_APPLICATION_END 255) - -(define CLOS_HAS_REST 1) -(define CLOS_HAS_REF_ARGS 2) -(define CLOS_PRESERVES_MARKS 4) -(define CLOS_IS_METHOD 16) -(define CLOS_SINGLE_RESULT 32) - -(define BITS_PER_MZSHORT 32) - -(define *dummy* #f) - -(define (int->bytes x) - (integer->integer-bytes x - 4 - #f - #f)) - -(define-struct case-seq (name lams)) - -(define-struct out (s shared-index)) - -(define (out-shared v out k) - (let ([v ((out-shared-index out) v)]) - (if v - (begin - (out-byte CPT_SYMREF out) - (out-number v out)) - (k)))) - -(define (out-byte v out) - (write-byte v (out-s out))) - -(define (out-bytes b out) - (write-bytes b (out-s out))) - -(define (out-number n out) - (cond - [(n . < . 0) - (if (n . > . -32) - (out-byte (bitwise-ior #xC0 (- n)) out) - (begin - (out-byte #xE0 out) - (out-bytes (int->bytes (- n)) out)))] - [(n . < . 128) - (out-byte n out)] - [(n . < . #x4000) - (out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out) - (out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)] - [else - (out-bytes #xF0 out) - (out-bytes (int->bytes n) out)])) - -(define (out-syntax key val out) - (out-marshaled syntax-type-num (list* key val) out)) - -(define (out-marshaled type-num val out) - (out-byte CPT_MARSHALLED out) - (out-number type-num out) - (out-data val out)) - -(define (out-anything v out) - (cond - [(module-variable? v) - (out-toplevel v out)] - [(closure? v) - (out-expr v out)] - [else - (out-data v out)])) - -(define (out-prefix a-prefix out) - (match a-prefix - [(struct prefix (num-lifts toplevels stxs)) - (out-marshaled - prefix-type-num - (cons num-lifts - (cons (list->vector toplevels) - (list->vector stxs))) - out)])) - -(define (out-module mod-form out) - (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) - (error "cannot write modules, yet")])) - -(define (out-toplevel tl out) - (match tl - [#f (out-data tl out)] - [(? symbol?) (out-data tl out)] - [(struct global-bucket (name)) - (out-marshaled variable-type-num name out)] - [(struct module-variable (modidx sym pos phase)) - (out-shared - tl - out - (lambda () - (out-byte CPT_MODULE_VAR out) - (let-values ([(p b) (module-path-index-split modidx)]) - (if (symbol? p) - (out-data p out) - (out-data modidx out))) - (out-data sym out) - (unless (zero? phase) - (out-number -2 out)) - (out-number pos out)))])) - -(define (out-stx tl out) - (error "cannot handle syntax objects, yet")) - -(define (out-form form out) - (match form - [(? mod?) - (out-module form out)] - [(struct def-values (ids rhs)) - (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons rhs ids)) - out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_SYNTAX_EXPD - (list->vector (list* rhs - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* rhs - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct seq (forms)) - (out-marshaled sequence-type-num (map protect-quote forms) out)] - [(struct splice (forms)) - (out-syntax SPLICE_EXPD (make-seq forms) out)] - [else - (out-expr form out)])) - -(define (out-expr expr out) - (match expr - [(struct toplevel (depth pos const? ready?)) - (out-marshaled toplevel-type-num - (if (or const? ready?) - (cons pos - (bitwise-ior - (if const? #x1 0) - (if ready? #x2 0))) - pos) - out)] - [(struct topsyntax (depth pos midpt)) - (out-marshaled quote-syntax-type-num - (cons depth - (cons pos midpt)) - out)] - [(struct primval (id)) - (out-byte CPT_REFERENCE out) - (out-number id out)] - [(struct assign (id rhs undef-ok?)) - (out-syntax SET_EXPD - (cons undef-ok? (cons id rhs)) - out)] - [(struct localref (unbox? offset clear? other-clears?)) - (if (and (not clear?) (not other-clears?) - (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) - (out-byte (+ (if unbox? - CPT_SMALL_LOCAL_UNBOX_START - CPT_SMALL_LOCAL_START) - offset) - out) - (begin - (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears?)) - (out-number offset out) - (begin - (out-number (- (add1 offset)) out) - (out-number (+ (if clear? #x1 0) - (if other-clears? #x2 0)) - out)))))] - [(? lam?) - (out-lam expr out)] - [(struct case-lam (name lams)) - (out-syntax CASE_LAMBDA_EXPD - (make-case-seq name lams))] - [(struct case-seq (name lams)) - (out-marshaled case-lambda-sequence-type-num - (cons (or name null) - lams) - out)] - [(struct let-one (rhs body)) - (out-byte CPT_LET_ONE out) - (out-expr (protect-quote rhs) out) - (out-expr (protect-quote body) out)] - [(struct let-void (count boxes? body)) - (out-marshaled let-void-type-num - (list* - count - boxes? - (protect-quote body)) - out)] - [(struct let-rec (procs body)) - (out-marshaled letrec-type-num - (list* - (length procs) - (protect-quote body) - procs) - out)] - [(struct install-value (count pos boxes? rhs body)) - (out-marshaled let-value-type-num - (list* - count - pos - boxes? - (protect-quote rhs) - (protect-quote body)) - out)] - [(struct boxenv (pos body)) - (out-syntax BOXENV_EXPD - (cons - pos - (protect-quote body)) - out)] - [(struct branch (test then else)) - (out-byte CPT_BRANCH out) - (out-expr (protect-quote test) out) - (out-expr (protect-quote then) out) - (out-expr (protect-quote else) out)] - [(struct application (rator rands)) - (if ((length rands) . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) - (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) - (begin - (out-byte CPT_APPLICATION out) - (out-number (length rands) out))) - (for-each (lambda (e) (out-expr (protect-quote e) out)) - (cons rator rands))] - [(struct apply-values (proc args-expr)) - (out-syntax APPVALS_EXPD - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] - [(struct seq (exprs)) - (out-form expr out)] - [(struct beg0 (exprs)) - (out-syntax BEGIN0_EXPD - (make-seq exprs) - out)] - [(struct with-cont-mark (key val body)) - (out-marshaled wcm-type-num - (list* - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] - [(struct closure (lam gen-id)) - (out-lam expr out)] - [(struct indirect (val)) - (out-expr val out)] - [else (out-value expr out)])) - -(define (out-lam expr out) - (match expr - [(struct indirect (val)) (out-lam expr out)] - [(struct closure (lam gen-id)) - (out-shared - expr - out - (lambda () - (out-lam expr out)))] - [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) - (let* ([l (protect-quote body)] - [any-refs? (ormap (lambda (t) (eq? t 'ref)) param-types)] - [l (cons (make-svector (if any-refs? - (list->vector - (append - (vector->list closure-map) - (let ([v (make-vector (ceiling (/ num-params BITS_PER_MZSHORT)))]) - (for ([t (in-list param-types)] - [i (in-naturals)]) - (when (eq? t 'ref) - (let ([pos (quotient i BITS_PER_MZSHORT)]) - (vector-set! v pos - (bitwise-ior (vector-ref v pos) - (arithmetic-shift 1 (modulo i BITS_PER_MZSHORT))))))) - (vector->list v)))) - closure-map)) - l)] - [l (if any-refs? - (cons (vector-length closure-map) l) - l)]) - (out-marshaled unclosed-procedure-type-num - (list* - (+ (if rest? CLOS_HAS_REST 0) - (if any-refs? CLOS_HAS_REF_ARGS 0) - (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) - (if (memq 'is-method flags) CLOS_IS_METHOD 0) - (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) - num-params - max-let-depth - name - l) - out))])) - -(define (out-as-bytes expr ->bytes CPT out) - (out-shared expr out (lambda () - (let ([s (->bytes expr)]) - (out-byte CPT out) - (out-number (bytes-length s) out) - (out-bytes s out))))) - -(define (out-data expr out) - (cond - [(prefix? expr) (out-prefix expr out)] - [else (out-form expr out)])) - -(define (out-value expr out) - (cond - [(symbol? expr) - (out-as-bytes expr - (compose string->bytes/utf-8 symbol->string) - CPT_SYMBOL - out)] - [(keyword? expr) - (out-as-bytes expr - (compose string->bytes/utf-8 keyword->string) - CPT_KEYWORD - out)] - [(string? expr) - (out-as-bytes expr - string->bytes/utf-8 - CPT_CHAR_STRING - out)] - [(bytes? expr) - (out-as-bytes expr - values - CPT_BYTE_STRING - out)] - [(path? expr) - (out-as-bytes expr - path->bytes - CPT_PATH - out)] - [(char? expr) - (out-byte CPT_CHAR out) - (out-number (char->integer expr) out)] - [(and (exact-integer? expr) - (and (expr . >= . -1073741824) (expr . <= . 1073741823))) - (out-byte CPT_INT out) - (out-number expr out)] - [(null? expr) - (out-byte CPT_NULL out)] - [(eq? expr #t) - (out-byte CPT_TRUE out)] - [(eq? expr #f) - (out-byte CPT_FALSE out)] - [(void? expr) - (out-byte CPT_VOID out)] - [(box? expr) - (out-byte CPT_BOX out) - (out-data (unbox expr) out)] - [(pair? expr) - (out-byte CPT_LIST out) - (out-number 1 out) - (out-data (car expr) out) - (out-data (cdr expr) out)] - [(vector? expr) - (out-byte CPT_VECTOR out) - (out-number (vector-length expr) out) - (for ([v (in-vector expr)]) - (out-data v out))] - [(hash? expr) - (out-byte CPT_HASH_TABLE out) - (out-number (cond - [(hash-eqv? expr) 2] - [(hash-eq? expr) 0] - [else 1])) - (for ([(k v) (in-hash expr)]) - (out-data k out) - (out-data v out))] - [(svector? expr) - (error "fixme svector")] - [else - (out-byte CPT_QUOTE out) - (let ([s (open-output-bytes)]) - (write (if (quoted? expr) (quoted-v expr) expr) s) - (out-bytes (get-output-bytes s) out))])) - -(define-struct quoted (v)) -(define (protect-quote v) - (if (or (list? v) (vector? v) (box? v) (hash? v)) - (make-quoted v) - v)) - -(define-struct svector (vec)) - -;; ---------------------------------------- - diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 8091e93e1b..4102326db6 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -578,7 +578,7 @@ (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) (if (memq 'is-method flags) CLOS_IS_METHOD 0) (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) - ((if rest? add1 0) num-params) + ((if rest? add1 values) num-params) max-let-depth name l) From c350bac4dd0528a70bf654ce860cd4053fb3156f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Mar 2009 17:37:28 +0000 Subject: [PATCH 091/466] some zo-marshal repairs svn: r13984 original commit: 946a39221a679039e292baa3c94a8c260a1642de --- collects/compiler/zo-marshal.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 4102326db6..4bcdf84009 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -663,8 +663,9 @@ [(svector? expr) (out-byte CPT_SVECTOR out) (out-number (vector-length (svector-vec expr)) out) - (for ([n (in-vector (svector-vec expr))]) - (out-number n out))] + (let ([vec (svector-vec expr)]) + (for ([n (in-range (sub1 (vector-length vec)) -1 -1)]) + (out-number (vector-ref vec n) out)))] [else (out-byte CPT_QUOTE out) (let ([s (open-output-bytes)]) From bd5bfaba1ccbef822b449bccae6ac86d18d761a5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Mar 2009 23:27:10 +0000 Subject: [PATCH 092/466] all expression forms tested for zo-marshal svn: r13998 original commit: 282a404ada78dd7a0969c8be13ec179dafc53a0e --- collects/compiler/zo-marshal.ss | 52 +++++++++++++++++++++++++-------- collects/compiler/zo-parse.ss | 2 +- 2 files changed, 41 insertions(+), 13 deletions(-) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 4bcdf84009..7a25602588 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -129,14 +129,14 @@ [(struct primval (id)) (void)] [(struct assign (id rhs undef-ok?)) - (traverse-expr rhs)] + (traverse-expr rhs visit)] [(struct localref (unbox? offset clear? other-clears?)) (void)] [(? lam?) (traverse-lam expr visit)] [(struct case-lam (name lams)) (traverse-data name visit) - (for-each (lambda (lam) (traverse-lam expr visit)) lams)] + (for-each (lambda (lam) (traverse-lam lam visit)) lams)] [(struct let-one (rhs body)) (traverse-expr rhs visit) (traverse-expr body visit)] @@ -212,6 +212,7 @@ (define variable-type-num 24) (define top-type-num 87) (define case-lambda-sequence-type-num 96) +(define begin0-sequence-type-num 97) (define prefix-type-num 103) (define-syntax define-enum @@ -300,6 +301,7 @@ #f)) (define-struct case-seq (name lams)) +(define-struct (seq0 seq) ()) (define-struct out (s shared-index)) @@ -414,6 +416,8 @@ *dummy* ids)) out)] + [(struct seq0 (forms)) + (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] [(struct seq (forms)) (out-marshaled sequence-type-num (map protect-quote forms) out)] [(struct splice (forms)) @@ -425,12 +429,14 @@ (match expr [(struct toplevel (depth pos const? ready?)) (out-marshaled toplevel-type-num - (if (or const? ready?) - (cons pos - (bitwise-ior - (if const? #x1 0) - (if ready? #x2 0))) - pos) + (cons + depth + (if (or const? ready?) + (cons pos + (bitwise-ior + (if const? #x1 0) + (if ready? #x2 0))) + pos)) out)] [(struct topsyntax (depth pos midpt)) (out-marshaled quote-syntax-type-num @@ -464,8 +470,17 @@ [(? lam?) (out-lam expr out)] [(struct case-lam (name lams)) - (out-syntax CASE_LAMBDA_EXPD - (make-case-seq name lams))] + (let ([seq (make-case-seq name lams)]) + ;; If all closures are empy, generate a case sequence directly + (if (andmap (lambda (lam) + (or (closure? lam) + (and (lam? lam) + (equal? (lam-closure-map lam) #())))) + lams) + (out-data seq out) + (out-syntax CASE_LAMBDA_EXPD + seq + out)))] [(struct case-seq (name lams)) (out-marshaled case-lambda-sequence-type-num (cons (or name null) @@ -526,7 +541,7 @@ (out-form expr out)] [(struct beg0 (exprs)) (out-syntax BEGIN0_EXPD - (make-seq exprs) + (make-seq0 exprs) out)] [(struct with-cont-mark (key val body)) (out-marshaled wcm-type-num @@ -539,6 +554,10 @@ (out-lam expr out)] [(struct indirect (val)) (out-expr val out)] + [(struct varref (expr)) + (out-syntax REF_EXPD + expr + out)] [else (out-value expr out)])) (define (out-lam expr out) @@ -549,7 +568,9 @@ expr out (lambda () - (out-lam expr out)))] + (out-byte CPT_CLOSURE out) + (out-number ((out-shared-index out) expr) out) + (out-lam lam out)))] [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) (let* ([l (protect-quote body)] [any-refs? (ormap (lambda (t) (eq? t 'ref)) param-types)] @@ -594,6 +615,8 @@ (define (out-data expr out) (cond [(prefix? expr) (out-prefix expr out)] + [(global-bucket? expr) (out-toplevel expr out)] + [(module-variable? expr) (out-toplevel expr out)] [else (out-form expr out)])) (define (out-value expr out) @@ -666,6 +689,11 @@ (let ([vec (svector-vec expr)]) (for ([n (in-range (sub1 (vector-length vec)) -1 -1)]) (out-number (vector-ref vec n) out)))] + [(module-path-index? expr) + (out-byte CPT_MODULE_INDEX out) + (let-values ([(name base) (module-path-index-split expr)]) + (out-data name out) + (out-data base out))] [else (out-byte CPT_QUOTE out) (let ([s (open-output-bytes)]) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index f03d22ee85..49e6ccd3ae 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -214,7 +214,7 @@ (define (read-apply-values v) (make-apply-values (car v) (cdr v))) (define (read-splice v) - (make-splice v)) + (make-splice (seq-forms v))) (define (read-module v) (match v From dd550f0a77bbeb1ef3cc039f0bcadf5fe9b630ef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Mar 2009 18:38:18 +0000 Subject: [PATCH 093/466] better eof handling in zo-parse svn: r14252 original commit: 3b490389470c977be372a943ccc03bfb1b8ae25f --- collects/compiler/zo-parse.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 49e6ccd3ae..b4d4375997 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -927,7 +927,7 @@ (define rst (read-bytes size* port)) - (unless (eof-object? (read port)) + (unless (eof-object? (read-byte port)) (error 'not-end)) (unless (= size* (bytes-length rst)) From 5b767d0b0832a143e8820855dd77b060788f3448 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 14:59:09 +0000 Subject: [PATCH 094/466] (v4.1.5.5) repair interaction of provides redirected by a rename-transformer, certification of access to unexported variables, and protected exports; also get rid of kernel-reprovide special case in export handling, because a more general export-sharing technique subsumed the special case long ago svn: r14593 original commit: cd09b304979146601302ff5f76e63465320bb313 --- collects/compiler/zo-parse.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index b4d4375997..538e065a4c 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -220,14 +220,14 @@ (match v [`(,name ,self-modidx ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy - ,prefix ,kernel-exclusion ,reprovide-kernel? + ,prefix ,indirect-provides ,num-indirect-provides ,indirect-syntax-provides ,num-indirect-syntax-provides ,indirect-et-provides ,num-indirect-et-provides ,protects ,et-protects ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 8 provide-phase-count))]) - (match (list-tail rest (* 8 provide-phase-count)) + (let ([phase-data (take rest (* 9 provide-phase-count))]) + (match (list-tail rest (* 9 provide-phase-count)) [`(,syntax-body ,body ,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) @@ -729,6 +729,7 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t]) + (printf "~s\n" s) (read (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] From 0a8691e0bb2f28e052db0734929c94c1036ce717 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 15:49:24 +0000 Subject: [PATCH 095/466] fix accidental commit of debugging printf svn: r14595 original commit: 6df0ac6f5163ff82130cfeee1f2c9d0990eaed13 --- collects/compiler/zo-parse.ss | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 538e065a4c..bb76d1fb8b 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -729,7 +729,6 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t]) - (printf "~s\n" s) (read (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] From cd3f1c87070ce6d5eea67a83751de65c7291dbaa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 17:34:49 +0000 Subject: [PATCH 096/466] fix zo-parse problem with graphs in literal data svn: r14596 original commit: 2439b4cb75c3b92179d764fb7dbe6f8c932a0f9f --- collects/compiler/zo-parse.ss | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index bb76d1fb8b..6660c45300 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -729,7 +729,7 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t]) - (read (open-input-bytes s))))] + (read/recursive (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] [(small-list small-proper-list) @@ -837,7 +837,17 @@ [(box) (box (read-compact cp))] [(quote) - (make-reader-graph (read-compact cp))] + (make-reader-graph + ;; Nested escapes need to share graph references. So get inside the + ;; read where `read/recursive' can be used: + (let ([rt (current-readtable)]) + (parameterize ([current-readtable (make-readtable + #f + #\x 'terminating-macro + (lambda args + (parameterize ([current-readtable rt]) + (read-compact cp))))]) + (read (open-input-bytes #"x")))))] [(symref) (let* ([l (read-compact-number cp)] [v (vector-ref (cport-symtab cp) l)]) From 3b13ccd8fe32b77166cf04cc52b4619057e2f359 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Apr 2009 13:13:22 +0000 Subject: [PATCH 097/466] zo-marshal supports module forms svn: r14637 original commit: 39d405fe6e52329e802fb836324ac7b75e922de2 --- collects/compiler/decompile.ss | 5 +- collects/compiler/zo-marshal.ss | 121 ++++++++++++++++++++++++++++---- collects/compiler/zo-parse.ss | 46 +++++++++++- 3 files changed, 154 insertions(+), 18 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 23a9b70652..819e86569b 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -90,7 +90,8 @@ (define (decompile-module mod-form stack) (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) + [(struct mod (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) (let-values ([(globs defns) (decompile-prefix prefix)] [(stack) (append '(#%modvars) stack)] [(closed) (make-hasheq)]) @@ -135,6 +136,8 @@ `(begin ,@(map (lambda (form) (decompile-form form globs stack closed)) forms))] + [(struct req (reqs dummy)) + `(#%require . (#%decode-syntax ,reqs))] [else (decompile-expr form globs stack closed)])) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 7a25602588..1bce9921d8 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -71,23 +71,26 @@ (define (traverse-prefix a-prefix visit) (match a-prefix [(struct prefix (num-lifts toplevels stxs)) - (for-each (lambda (stx) (traverse-toplevel stx visit)) stxs) + (for-each (lambda (stx) (traverse-toplevel stx visit)) toplevels) (for-each (lambda (stx) (traverse-stx stx visit)) stxs)])) (define (traverse-module mod-form visit) (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) - (error "cannot handle modules, yet") + [(struct mod (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) (traverse-data name visit) (traverse-data self-modidx visit) (traverse-prefix prefix visit) + (for-each (lambda (f) (map (lambda (v) (traverse-data v visit)) (cdr f))) requires) (for-each (lambda (f) (traverse-form f prefix)) body) - (for-each (lambda (f) (traverse-form f prefix)) syntax-body)])) + (for-each (lambda (f) (traverse-form f prefix)) syntax-body) + (traverse-data lang-info visit) + (traverse-data internal-context visit)])) (define (traverse-toplevel tl visit) (match tl [#f (void)] - [(? symbol?) (visit tl)] + [(? symbol?) (traverse-data tl visit)] [(struct global-bucket (name)) (void)] [(struct module-variable (modidx sym pos phase)) @@ -180,9 +183,13 @@ (keyword? expr) (string? expr) (bytes? expr) - (path? expr) - (module-path-index? expr)) + (path? expr)) (visit expr)] + [(module-path-index? expr) + (visit expr) + (let-values ([(name base) (module-path-index-split expr)]) + (traverse-data name visit) + (traverse-data base visit))] [(pair? expr) (traverse-data (car expr) visit) (traverse-data (cdr expr) visit)] @@ -213,6 +220,7 @@ (define top-type-num 87) (define case-lambda-sequence-type-num 96) (define begin0-sequence-type-num 97) +(define module-type-num 100) (define prefix-type-num 103) (define-syntax define-enum @@ -363,10 +371,80 @@ (list->vector stxs))) out)])) +(define-struct module-decl (content)) + (define (out-module mod-form out) (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) - (error "cannot write modules, yet")])) + [(struct mod (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) + (out-syntax MODULE_EXPD + (let* ([lookup-req (lambda (phase) + (let ([a (assq phase requires)]) + (if a + (cdr a) + null)))] + [other-requires (filter (lambda (l) + (not (memq (car l) '(#f -1 0 1)))) + requires)] + [extract-protects + (lambda (phase) + (let ([a (assq phase provides)]) + (and a + (let ([p (map provided-protected? (append (cadr a) + (caddr a)))]) + (if (ormap values p) + (list->vector p) + #f)))))] + [list->vector/#f (lambda (default l) + (if (andmap (lambda (x) (equal? x default)) l) + #f + (list->vector l)))] + [l (map cdr other-requires)] + [l (cons (length other-requires) l)] + [l (cons (lookup-req #f) l)] ; dt-requires + [l (cons (lookup-req -1) l)] ; tt-requires + [l (cons (lookup-req 1) l)] ; et-requires + [l (cons (lookup-req 0) l)] ; requires + [l (cons (list->vector body) l)] + [l (cons (list->vector syntax-body) l)] + [l (append (apply + append + (map (lambda (l) + (let ([phase (car l)] + [all (append (cadr l) (caddr l))]) + (list phase + (list->vector/#f #f (map provided-insp all)) + (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) + all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all)))) + provides)) + l)] + [l (cons (length provides) l)] ; number of provide sets + [l (cons (extract-protects 0) l)] ; protects + [l (cons (extract-protects 1) l)] ; et protects + [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides + [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides + [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides + [l (cons prefix l)] + [l (cons dummy l)] + [l (cons max-let-depth l)] + [l (cons internal-context l)] ; module->namespace syntax + [l (list* #f #f l)] ; obsolete `functional?' info + [l (cons lang-info l)] ; lang-info + [l (cons self-modidx l)] + [l (cons name l)]) + (make-module-decl l)) + out)])) (define (out-toplevel tl out) (match tl @@ -422,6 +500,9 @@ (out-marshaled sequence-type-num (map protect-quote forms) out)] [(struct splice (forms)) (out-syntax SPLICE_EXPD (make-seq forms) out)] + [(struct req (reqs dummy)) + (error "cannot handle top-level `require', yet") + (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] [else (out-expr form out)])) @@ -605,11 +686,12 @@ l) out))])) -(define (out-as-bytes expr ->bytes CPT out) +(define (out-as-bytes expr ->bytes CPT len2 out) (out-shared expr out (lambda () (let ([s (->bytes expr)]) (out-byte CPT out) (out-number (bytes-length s) out) + (when len2 (out-number len2 out)) (out-bytes s out))))) (define (out-data expr out) @@ -625,26 +707,31 @@ (out-as-bytes expr (compose string->bytes/utf-8 symbol->string) CPT_SYMBOL + #f out)] [(keyword? expr) (out-as-bytes expr (compose string->bytes/utf-8 keyword->string) CPT_KEYWORD + #f out)] [(string? expr) (out-as-bytes expr string->bytes/utf-8 CPT_CHAR_STRING + (string-length expr) out)] [(bytes? expr) (out-as-bytes expr values CPT_BYTE_STRING + #f out)] [(path? expr) (out-as-bytes expr path->bytes CPT_PATH + #f out)] [(char? expr) (out-byte CPT_CHAR out) @@ -690,10 +777,16 @@ (for ([n (in-range (sub1 (vector-length vec)) -1 -1)]) (out-number (vector-ref vec n) out)))] [(module-path-index? expr) - (out-byte CPT_MODULE_INDEX out) - (let-values ([(name base) (module-path-index-split expr)]) - (out-data name out) - (out-data base out))] + (out-shared expr out + (lambda () + (out-byte CPT_MODULE_INDEX out) + (let-values ([(name base) (module-path-index-split expr)]) + (out-data name out) + (out-data base out))))] + [(module-decl? expr) + (out-marshaled module-type-num + (module-decl-content expr) + out)] [else (out-byte CPT_QUOTE out) (let ([s (open-output-bytes)]) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 6660c45300..1f04af58ec 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -34,7 +34,8 @@ (define-form-struct form ()) (define-form-struct (expr form) ()) -(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth)) +(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) (define-form-struct (lam expr) (name flags num-params param-types rest? closure-map max-let-depth body)) ; `lambda' (define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) @@ -74,6 +75,9 @@ (define-struct indirect ([v #:mutable]) #:prefab) (provide (struct-out indirect)) +;; A provided identifier +(define-form-struct provided (name src src-name nom-src src-phase protected? insp)) + ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -232,7 +236,37 @@ ,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) (make-mod name self-modidx - prefix phase-data + prefix (let loop ([l phase-data]) + (if (null? l) + null + (let ([num-vars (list-ref l 7)] + [ps (for/list ([name (in-vector (list-ref l 6))] + [src (in-vector (list-ref l 5))] + [src-name (in-vector (list-ref l 4))] + [nom-src (or (list-ref l 3) + (in-cycle (in-value #f)))] + [src-phase (or (list-ref l 2) + (in-cycle (in-value #f)))] + [protected? (or (case (car l) + [(0) protects] + [(1) et-protects] + [else #f]) + (in-cycle (in-value #f)))] + [insp (or (list-ref l 1) + (in-cycle (in-value #f)))]) + (make-provided name src src-name + (or nom-src src) + (if src-phase 1 0) + protected? + insp))]) + (if (null? ps) + (loop (list-tail l 9)) + (cons + (list + (car l) + (take ps num-vars) + (drop ps num-vars)) + (loop (list-tail l 9))))))) (list* (cons 0 requires) (cons 1 syntax-requires) @@ -248,7 +282,13 @@ make-def-syntaxes) ids expr prefix max-let-depth)])) (vector->list syntax-body)) - max-let-depth)]))])) + (list (vector->list indirect-provides) + (vector->list indirect-syntax-provides) + (vector->list indirect-et-provides)) + max-let-depth + dummy + lang-info + rename)]))])) (define (read-module-wrap v) v) From 57312ea2d5e3c688fd723cef227bc3f80a81d4fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Apr 2009 16:37:16 +0000 Subject: [PATCH 098/466] zo-marshal patch from Jay svn: r14642 original commit: b42f1b5d8bd8b7d9a15f7a0db6a5dcf73f4caac9 --- collects/compiler/zo-marshal.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 1bce9921d8..5c0a17db8e 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -5,7 +5,7 @@ (provide zo-marshal) ;; Doesn't write as compactly as MzScheme, since list and pair sequences -;; are not compated, and symbols are not written in short form +;; are not compacted, and symbols are not written in short form (define (zo-marshal top) (match top @@ -82,8 +82,8 @@ (traverse-data self-modidx visit) (traverse-prefix prefix visit) (for-each (lambda (f) (map (lambda (v) (traverse-data v visit)) (cdr f))) requires) - (for-each (lambda (f) (traverse-form f prefix)) body) - (for-each (lambda (f) (traverse-form f prefix)) syntax-body) + (for-each (lambda (f) (traverse-form f visit)) body) + (for-each (lambda (f) (traverse-form f visit)) syntax-body) (traverse-data lang-info visit) (traverse-data internal-context visit)])) From 8caf639791b58509790f8d477bb34a13b2f26558 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 17 May 2009 12:31:51 +0000 Subject: [PATCH 099/466] identifier-prune-lexical-context (4.2.0.2) svn: r14850 original commit: 70859f0d0bcb1b67fccd16208dfa5cd9289dfd2e --- collects/compiler/zo-parse.ss | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 1f04af58ec..8af27954f9 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -505,6 +505,7 @@ (define-form-struct wrap ()) (define-form-struct (lexical-rename wrap) (alist)) (define-form-struct (phase-shift wrap) (amt src dest)) +(define-form-struct (prune wrap) (sym)) (define-form-struct (module-rename wrap) (phase kind set-id unmarshals renames mark-renames plus-kern?)) (define-form-struct all-from-module (path phase src-phase exceptions prefix)) @@ -691,6 +692,7 @@ '(#%mark-barrier)] [(box? a) (match (unbox a) + [(list (? symbol?) ...) (make-prune (unbox a))] [`#(,amt ,src ,dest #f) (make-phase-shift amt (parse-module-path-index cp src) From 95420f055dbb8c286a8c254a91a899399add74bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 6 Sep 2009 18:24:46 +0000 Subject: [PATCH 100/466] unsafe ops (v4.2.1.8) svn: r15899 original commit: 8ae0ea9d14716c94f73c5c85f8278934fe85fe15 --- collects/compiler/decompile.ss | 3 ++- collects/compiler/zo-parse.ss | 9 ++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 819e86569b..8729a983b1 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -13,6 +13,7 @@ (let ([ns (make-base-empty-namespace)]) (parameterize ([current-namespace ns]) (namespace-require ''#%kernel) + (namespace-require ''#%unsafe) (for/list ([l (namespace-mapped-symbols)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))))))] @@ -320,7 +321,7 @@ list list* vector vector-immutable box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? - + - * / min max bitwise-and bitwise-ior + + - * / quotient remainder min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons list list* vector vector-immutable))] diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 8af27954f9..397f585e31 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -113,9 +113,12 @@ (make-compilation-top ld prefix code)])) (define (read-resolve-prefix v) - (match v - [`(,i ,tv . ,sv) - (make-prefix i (vector->list tv) (vector->list sv))])) + (let-values ([(v unsafe?) (if (integer? (car v)) + (values v #f) + (values (cdr v) #t))]) + (match v + [`(,i ,tv . ,sv) + (make-prefix i (vector->list tv) (vector->list sv))]))) (define (read-unclosed-procedure v) (define CLOS_HAS_REST 1) From 4e9963b06bc94c9a43e835d6e8f5bbd37199aeba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Oct 2009 23:39:29 +0000 Subject: [PATCH 101/466] update decompiler for changed type number svn: r16227 original commit: 7529e8d4a9fc2079e2a6f2cc3eaa64a833600b92 --- collects/compiler/zo-parse.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 397f585e31..26b995b618 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -334,7 +334,7 @@ [(96) 'case-lambda-sequence-type] [(97) 'begin0-sequence-type] [(100) 'module-type] - [(103) 'resolve-prefix-type] + [(102) 'resolve-prefix-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers From 06aeb59448300822819543d1d80e0b45e55bb49a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Nov 2009 15:07:16 +0000 Subject: [PATCH 102/466] add unsafe-f64vector-{ref,set!} and improve JIT to inline arithmetic ops with more than 2 arguments svn: r17068 original commit: 61dd4ca0b9a66e1982856cb7b8447fac9efdf23b --- collects/compiler/decompile.ss | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 8729a983b1..0ebc8b28a6 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -321,13 +321,15 @@ list list* vector vector-immutable box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? - + - * / quotient remainder min max bitwise-and bitwise-ior + + - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons list list* vector vector-immutable))] [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list list* vector vector-immutable))] - [else (memq (car a) '(list list* vector vector-immutable))])) + list list* vector vector-immutable + + - * / min max bitwise-and bitwise-ior bitwise-xor))] + [else (memq (car a) '(list list* vector vector-immutable + + - * / min max bitwise-and bitwise-ior bitwise-xor))])) (cons '#%in a) a)) From b1aeeac4a9061c453234cc536401fa08334beb73 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 Dec 2009 04:39:46 +0000 Subject: [PATCH 103/466] bytecode-compiler changes to help enable flonum unboxing svn: r17283 original commit: 5772fa0a9f595a8852638a5b1c0de7de2dbb0ef2 --- collects/compiler/decompile.ss | 35 +++++++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 0ebc8b28a6..bb40aaf288 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -246,11 +246,13 @@ [(struct application (rator rands)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) stack)]) - (annotate-inline - `(,(decompile-expr rator globs stack closed) - ,@(map (lambda (rand) - (decompile-expr rand globs stack closed)) - rands))))] + (annotate-unboxed + rands + (annotate-inline + `(,(decompile-expr rator globs stack closed) + ,@(map (lambda (rand) + (decompile-expr rand globs stack closed)) + rands)))))] [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack closed) ,(decompile-expr args-expr globs stack closed))] @@ -333,6 +335,29 @@ (cons '#%in a) a)) +(define (annotate-unboxed args a) + (define (unboxable? e s) + (cond + [(localref? e) #t] + [(toplevel? e) #t] + [(eq? '#%flonum (car s)) #t] + [(not (expr? e)) #t] + [else #f])) + (if (and (symbol? (car a)) + (case (length a) + [(2) (memq (car a) '(unsafe-flabs + unsafe-fx->fl))] + [(3) (memq (car a) '(unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ + unsafe-fl< unsafe-fl> + unsafe-fl= + unsafe-fl<= unsafe-fl>=))] + + [(4) (memq (car a) '(unsafe-flvector-set!))] + [else #f]) + (andmap unboxable? args (cdr a))) + (cons '#%flonum a) + a)) + ;; ---------------------------------------- #; From 66b8a274d7bd4d7c49964c93a36c409a23e08e8f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 16 Dec 2009 13:30:40 +0000 Subject: [PATCH 104/466] unboxing of let-bound flonums (v4.2.3.6) svn: r17328 original commit: 45e84ca087169d9a150b30f892f45de95ded9c65 --- collects/compiler/decompile.ss | 13 +++++++++---- collects/compiler/zo-marshal.ss | 21 +++++++++++++-------- collects/compiler/zo-parse.ss | 17 ++++++++++------- 3 files changed, 32 insertions(+), 19 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 75f2d7216a..15461c8866 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -189,14 +189,16 @@ [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack closed) ,(decompile-expr rhs globs stack closed))] - [(struct localref (unbox? offset clear? other-clears?)) + [(struct localref (unbox? offset clear? other-clears? flonum?)) (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) id)]) (if clear? `(#%sfs-clear ,e) - e)))] + (if flonum? + `(#%from-flonum ,e) + e))))] [(? lam?) `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) @@ -204,10 +206,13 @@ ,@(map (lambda (lam) (decompile-lam lam globs stack closed)) lams))] - [(struct let-one (rhs body)) + [(struct let-one (rhs body flonum?)) (let ([id (or (extract-id rhs) (gensym 'local))]) - `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) + `(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)]) + (if flonum? + (list '#%as-flonum v) + v))]) ,(decompile-expr body globs (cons id stack) closed)))] [(struct let-void (count boxes? body)) (let ([ids (make-vector count #f)]) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 5c0a17db8e..49669966a9 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -133,14 +133,14 @@ (void)] [(struct assign (id rhs undef-ok?)) (traverse-expr rhs visit)] - [(struct localref (unbox? offset clear? other-clears?)) + [(struct localref (unbox? offset clear? other-clears? flonum?)) (void)] [(? lam?) (traverse-lam expr visit)] [(struct case-lam (name lams)) (traverse-data name visit) (for-each (lambda (lam) (traverse-lam lam visit)) lams)] - [(struct let-one (rhs body)) + [(struct let-one (rhs body flonum?)) (traverse-expr rhs visit) (traverse-expr body visit)] [(struct let-void (count boxes? body)) @@ -252,7 +252,7 @@ CPT_VECTOR CPT_HASH_TABLE CPT_STX - CPT_GSTX + CPT_LET_ONE_FLONUM CPT_MARSHALLED CPT_QUOTE CPT_REFERENCE @@ -531,7 +531,7 @@ (out-syntax SET_EXPD (cons undef-ok? (cons id rhs)) out)] - [(struct localref (unbox? offset clear? other-clears?)) + [(struct localref (unbox? offset clear? other-clears? flonum?)) (if (and (not clear?) (not other-clears?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) (out-byte (+ (if unbox? @@ -545,8 +545,13 @@ (out-number offset out) (begin (out-number (- (add1 offset)) out) - (out-number (+ (if clear? #x1 0) - (if other-clears? #x2 0)) + (out-number (if clear? + #x1 + (if other-clears? + #x2 + (if flonum? + #x3 + 0))) out)))))] [(? lam?) (out-lam expr out)] @@ -567,8 +572,8 @@ (cons (or name null) lams) out)] - [(struct let-one (rhs body)) - (out-byte CPT_LET_ONE out) + [(struct let-one (rhs body flonum?)) + (out-byte (if flonum? CPT_LET_ONE_FLONUM CPT_LET_ONE) out) (out-expr (protect-quote rhs) out) (out-expr (protect-quote body) out)] [(struct let-void (count boxes? body)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 26b995b618..61cecff581 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -41,13 +41,13 @@ (define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) (define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam -(define-form-struct (let-one expr) (rhs body)) ; pushes one value onto stack +(define-form-struct (let-one expr) (rhs body flonum?)) ; pushes one value onto stack (define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots (define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s) (define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots (define-form-struct (boxenv expr) (pos body)) ; box existing stack element -(define-form-struct (localref expr) (unbox? pos clear? other-clears?)) ; access local via stack +(define-form-struct (localref expr) (unbox? pos clear? other-clears? flonum?)) ; access local via stack (define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack) (define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack) @@ -410,7 +410,7 @@ [16 vector] [17 hash-table] [18 stx] - [19 gstx] ; unused + [19 let-one-flonum] [20 marshalled] [21 quote] [22 reference] @@ -491,9 +491,11 @@ (define (make-local unbox? pos flags) (define SCHEME_LOCAL_CLEAR_ON_READ #x01) (define SCHEME_LOCAL_OTHER_CLEARS #x02) + (define SCHEME_LOCAL_FLONUM #x03) (make-localref unbox? pos - (positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ)) - (positive? (bitwise-and flags SCHEME_LOCAL_OTHER_CLEARS)))) + (= flags SCHEME_LOCAL_CLEAR_ON_READ) + (= flags SCHEME_LOCAL_OTHER_CLEARS) + (= flags SCHEME_LOCAL_FLONUM))) (define (a . << . b) (arithmetic-shift a b)) @@ -786,8 +788,9 @@ (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) (loop l ppr)))] - [(let-one) - (make-let-one (read-compact cp) (read-compact cp))] + [(let-one let-one-flonum) + (make-let-one (read-compact cp) (read-compact cp) + (eq? cpt-tag 'let-one-flonum))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))] From ab1cebd148a6010065d49300c4dea506f70091fd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 17 Dec 2009 15:58:29 +0000 Subject: [PATCH 105/466] unboxed known-flonum loop accumulators svn: r17338 original commit: bc47db42e4ead3442e3c5bd3b48ec585895e266e --- collects/compiler/decompile.ss | 3 ++- collects/compiler/zo-marshal.ss | 6 +++--- collects/compiler/zo-parse.ss | 13 +++++++------ 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 15461c8866..250fc75867 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -292,7 +292,7 @@ (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" - (if (eq? type 'ref) "argbox" "arg") + (case type [(ref) "argbox"] [(flonum) "argfl"] [else "arg"]) i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) @@ -351,6 +351,7 @@ (if (and (symbol? (car a)) (case (length a) [(2) (memq (car a) '(unsafe-flabs + unsafe-flsqrt unsafe-fx->fl))] [(3) (memq (car a) '(unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ unsafe-fl< unsafe-fl> diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 49669966a9..dce8346914 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -664,14 +664,14 @@ (list->vector (append (vector->list closure-map) - (let ([v (make-vector (ceiling (/ num-params BITS_PER_MZSHORT)))]) + (let ([v (make-vector (ceiling (/ (* 2 num-params) BITS_PER_MZSHORT)))]) (for ([t (in-list param-types)] [i (in-naturals)]) (when (eq? t 'ref) - (let ([pos (quotient i BITS_PER_MZSHORT)]) + (let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) (vector-set! v pos (bitwise-ior (vector-ref v pos) - (arithmetic-shift 1 (modulo i BITS_PER_MZSHORT))))))) + (arithmetic-shift 1 (modulo (* 2 i) BITS_PER_MZSHORT))))))) (vector->list v)))) closure-map)) l)] diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 61cecff581..c995346f7b 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -138,12 +138,13 @@ (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (for/list ([i (in-range num-params)]) 'val) (for/list ([i (in-range num-params)]) - (if (bitwise-bit-set? - (vector-ref closed-over - (+ closure-size (quotient i BITS_PER_MZSHORT))) - (remainder i BITS_PER_MZSHORT)) - 'ref - 'val))))]) + (let ([byte (vector-ref closed-over + (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) + (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) + 'ref + (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) + 'flonum + 'val))))))]) (make-lam name (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) From 2d1e7602c17f5b71f9a376463b48d3b742c49ce8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 17 Dec 2009 20:17:48 +0000 Subject: [PATCH 106/466] fix up validator, decompiler, and zo-marshaler for flonum-argument annotations svn: r17341 original commit: cab948d61f713399f5167875e9191ca754af4a0a --- collects/compiler/decompile.ss | 4 +-- collects/compiler/zo-marshal.ss | 50 ++++++++++++++++++++++----------- collects/compiler/zo-parse.ss | 34 ++++++++++++++-------- 3 files changed, 58 insertions(+), 30 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 250fc75867..5059b8dfa5 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -151,7 +151,7 @@ (define (extract-id expr) (match expr - [(struct lam (name flags num-params arg-types rest? closure-map max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) (extract-name name)] [(struct case-lam (name lams)) (extract-name name)] @@ -288,7 +288,7 @@ (match expr [(struct indirect (val)) (decompile-lam val globs stack closed)] [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] - [(struct lam (name flags num-params arg-types rest? closure-map max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index dce8346914..1d68f5f44c 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -21,6 +21,8 @@ #f) (begin (hash-set! encountered v #t) + (when (closure? v) + (hash-set! shared v (add1 (hash-count shared)))) #t))))]) (traverse-prefix prefix visit) (traverse-form form visit)) @@ -197,11 +199,11 @@ (define (traverse-lam expr visit) (match expr - [(struct indirect (val)) (traverse-lam expr visit)] + [(struct indirect (val)) (traverse-lam val visit)] [(struct closure (lam gen-id)) (when (visit expr) - (traverse-lam expr visit))] - [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) + (traverse-lam lam visit))] + [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) (traverse-data name visit) (traverse-expr body visit)])) @@ -221,7 +223,7 @@ (define case-lambda-sequence-type-num 96) (define begin0-sequence-type-num 97) (define module-type-num 100) -(define prefix-type-num 103) +(define prefix-type-num 102) (define-syntax define-enum (syntax-rules () @@ -532,7 +534,7 @@ (cons undef-ok? (cons id rhs)) out)] [(struct localref (unbox? offset clear? other-clears? flonum?)) - (if (and (not clear?) (not other-clears?) + (if (and (not clear?) (not other-clears?) (not flonum?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) (out-byte (+ (if unbox? CPT_SMALL_LOCAL_UNBOX_START @@ -541,7 +543,7 @@ out) (begin (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears?)) + (if (not (or clear? other-clears? flonum?)) (out-number offset out) (begin (out-number (- (add1 offset)) out) @@ -648,7 +650,7 @@ (define (out-lam expr out) (match expr - [(struct indirect (val)) (out-lam expr out)] + [(struct indirect (val)) (out-lam val out)] [(struct closure (lam gen-id)) (out-shared expr @@ -657,21 +659,32 @@ (out-byte CPT_CLOSURE out) (out-number ((out-shared-index out) expr) out) (out-lam lam out)))] - [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) + [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) (let* ([l (protect-quote body)] - [any-refs? (ormap (lambda (t) (eq? t 'ref)) param-types)] + [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) + (ormap (lambda (t) (memq t '(flonum))) closure-types))] + [num-all-params ((if rest? add1 values) num-params)] [l (cons (make-svector (if any-refs? (list->vector (append (vector->list closure-map) - (let ([v (make-vector (ceiling (/ (* 2 num-params) BITS_PER_MZSHORT)))]) + (let* ([v (make-vector (ceiling + (/ (* 2 (+ num-params (vector-length closure-map))) + BITS_PER_MZSHORT)))] + [set-bit! (lambda (i bit) + (let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) + (vector-set! v pos + (bitwise-ior (vector-ref v pos) + (arithmetic-shift + bit + (modulo (* 2 i) BITS_PER_MZSHORT))))))]) (for ([t (in-list param-types)] [i (in-naturals)]) - (when (eq? t 'ref) - (let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) - (vector-set! v pos - (bitwise-ior (vector-ref v pos) - (arithmetic-shift 1 (modulo (* 2 i) BITS_PER_MZSHORT))))))) + (when (eq? t 'ref) (set-bit! i 1)) + (when (eq? t 'flonum) (set-bit! i 2))) + (for ([t (in-list closure-types)] + [i (in-naturals num-all-params)]) + (when (eq? t 'flonum) (set-bit! i 2))) (vector->list v)))) closure-map)) l)] @@ -685,7 +698,7 @@ (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) (if (memq 'is-method flags) CLOS_IS_METHOD 0) (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) - ((if rest? add1 values) num-params) + num-all-params max-let-depth name l) @@ -796,7 +809,10 @@ (out-byte CPT_QUOTE out) (let ([s (open-output-bytes)]) (write (if (quoted? expr) (quoted-v expr) expr) s) - (out-bytes (get-output-bytes s) out))])) + (out-byte CPT_ESCAPE out) + (let ([bstr (get-output-bytes s)]) + (out-number (bytes-length bstr) out) + (out-bytes bstr out)))])) (define-struct quoted (v)) (define (protect-quote v) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index c995346f7b..6633050b26 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -37,7 +37,7 @@ (define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) -(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map max-let-depth body)) ; `lambda' +(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) ; `lambda' (define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) (define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam @@ -134,17 +134,28 @@ (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (values (vector-length v) v rest) (values v (car rest) (cdr rest)))] - [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + [(check-bit) (lambda (i) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - (for/list ([i (in-range num-params)]) 'val) - (for/list ([i (in-range num-params)]) - (let ([byte (vector-ref closed-over - (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) - (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) - 'ref - (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) - 'flonum - 'val))))))]) + 0 + (let ([byte (vector-ref closed-over + (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) + (+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) + 1 + 0) + (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) + 2 + 0)))))] + [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + (for/list ([i (in-range num-params)]) + (case (check-bit i) + [(0) 'val] + [(1) 'ref] + [(2) 'flonum])))] + [(closure-types) (for/list ([i (in-range closure-size)] + [j (in-naturals num-params)]) + (case (check-bit j) + [(0) 'val/ref] + [(2) 'flonum]))]) (make-lam name (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) @@ -158,6 +169,7 @@ (let ([v2 (make-vector closure-size)]) (vector-copy! v2 0 closed-over 0 closure-size) v2)) + closure-types max-let-depth body)))])) From 1b7935c819564c87cbd01a756ce80866b8696e0d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 18 Dec 2009 15:40:00 +0000 Subject: [PATCH 107/466] scheme/flonum (v4.2.3.8) svn: r17348 original commit: fdd71229944231e92f07ff61660e6cb9279a7e35 --- collects/compiler/decompile.ss | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 5059b8dfa5..8f650e09a1 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -14,6 +14,7 @@ (parameterize ([current-namespace ns]) (namespace-require ''#%kernel) (namespace-require ''#%unsafe) + (namespace-require ''#%flonum) (for/list ([l (namespace-mapped-symbols)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))))))] @@ -350,16 +351,23 @@ [else #f])) (if (and (symbol? (car a)) (case (length a) - [(2) (memq (car a) '(unsafe-flabs - unsafe-flsqrt - unsafe-fx->fl))] - [(3) (memq (car a) '(unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ - unsafe-fl< unsafe-fl> - unsafe-fl= - unsafe-fl<= unsafe-fl>= - unsafe-flvector-ref))] + [(2) (memq (car a) '(flabs flsqrt ->fl + unsafe-flabs + unsafe-flsqrt + unsafe-fx->fl))] + [(3) (memq (car a) '(fl+ fl- fl* fl/ + fl< fl> fl<= fl>= fl= + flvector-ref + unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ + unsafe-fl< unsafe-fl> + unsafe-fl= + unsafe-fl<= unsafe-fl>= + unsafe-flvector-ref + unsafe-f64vector-ref))] - [(4) (memq (car a) '(unsafe-flvector-set!))] + [(4) (memq (car a) '(flvector-set! + unsafe-flvector-set! + unsafe-f64vector-set!))] [else #f]) (andmap unboxable? args (cdr a))) (cons '#%flonum a) From 3b650e1e150a924b27c158bdbeab694b02e0b023 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 2 Jan 2010 16:33:28 +0000 Subject: [PATCH 108/466] built-in fixnum ops; bug fix related to misuse of flonum ops; questionable attempt to improve inlining algorithm svn: r17461 original commit: 38d7e8fea2185e65a33ddbed7d716aa29aa4e3d2 --- collects/compiler/decompile.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 8f650e09a1..ea43b590d3 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -14,7 +14,7 @@ (parameterize ([current-namespace ns]) (namespace-require ''#%kernel) (namespace-require ''#%unsafe) - (namespace-require ''#%flonum) + (namespace-require ''#%flfxnum) (for/list ([l (namespace-mapped-symbols)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))))))] From 0c18f10bf8cd6b30d8931b76e640f99441c0dde2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 7 Jan 2010 16:33:26 +0000 Subject: [PATCH 109/466] fix problem with flmin/flmax and cgc svn: r17532 original commit: f7f6b972fd7233fa0e7778959058831dec005a2c --- collects/compiler/decompile.ss | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index ea43b590d3..5a2ef58b79 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -354,12 +354,18 @@ [(2) (memq (car a) '(flabs flsqrt ->fl unsafe-flabs unsafe-flsqrt - unsafe-fx->fl))] + unsafe-fx->fl + flsin flcos fltan + flasin flacos flatan + flexp fllog + flfloor flceiling flround fltruncate + flmin flmax + unsafe-flmin unsafe-flmax))] [(3) (memq (car a) '(fl+ fl- fl* fl/ fl< fl> fl<= fl>= fl= flvector-ref unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ - unsafe-fl< unsafe-fl> + unsafe-fl< unsafe-fl> unsafe-fl= unsafe-fl<= unsafe-fl>= unsafe-flvector-ref From 6d26d894e18838335d1fedcbb3eb0b8bd58daf92 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Feb 2010 00:16:06 +0000 Subject: [PATCH 110/466] improve inling to support ((let (....) (lambda ....)) arg ...) patterns; allow nested 'let's for local flonum binding (which fixes a problem where unsafe flonum operations could end up much slower than safe ones) svn: r17972 original commit: 3812f8ca72c8845b4758f01a353ab81a60297d0a --- collects/compiler/decompile.ss | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 5a2ef58b79..cff92eccd5 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -307,7 +307,12 @@ null) ,@(if (null? captures) null - `('(captures: ,@captures))) + `('(captures: ,@(map (lambda (c t) + (if (eq? t 'flonum) + `(flonum ,c) + c)) + captures + closure-types)))) ,(decompile-expr body globs (append captures (append vars rest-vars)) From 3562d9f41684ccf9b3a5022a85e25132b4fd9775 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 17 Feb 2010 21:38:06 +0000 Subject: [PATCH 111/466] Forgot to add a file svn: r18131 original commit: 2ffa8cb34fae7a9c117e40b644eab6f83dc26b9c --- collects/compiler/zo-structs.ss | 201 ++++++++++++++++++++++++++++++++ 1 file changed, 201 insertions(+) create mode 100644 collects/compiler/zo-structs.ss diff --git a/collects/compiler/zo-structs.ss b/collects/compiler/zo-structs.ss new file mode 100644 index 0000000000..b015689cbb --- /dev/null +++ b/collects/compiler/zo-structs.ss @@ -0,0 +1,201 @@ +#lang scheme/base +(require mzlib/etc + scheme/match + scheme/contract + scheme/list) + +#| Unresolved issues + + what are the booleans in lexical-rename? + + contracts that are probably too generous: + prefix-stxs + provided-nom-src + lam-num-params + lexical-rename-alist + all-from-module + +|# + +;; ---------------------------------------- +;; Structures to represent bytecode + +(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) + (begin + (define-struct id+par (field-id ...) #:transparent) + (provide/contract + [struct id ([field-id field-contract] ...)]))) + +(define-syntax define-form-struct + (syntax-rules () + [(_ (id sup) . rest) + (define-form-struct* id (id sup) . rest)] + [(_ id . rest) + (define-form-struct* id id . rest)])) + +;; In toplevels of resove prefix: +(define-form-struct global-bucket ([name symbol?])) ; top-level binding +(define-form-struct module-variable ([modidx module-path-index?] + [sym symbol?] + [pos exact-integer?] + [phase (or/c 0 1)])) ; direct access to exported id + +;; Syntax object +(define-form-struct wrap ()) +(define-form-struct wrapped ([datum any/c] + [wraps (listof wrap?)] + [certs (or/c list? #f)])) + +;; In stxs of prefix: +(define-form-struct stx ([encoded wrapped?])) + +(define-form-struct prefix ([num-lifts exact-nonnegative-integer?] + [toplevels (listof (or/c #f symbol? global-bucket? module-variable?))] + [stxs list?])) ; should be (listof stx?) sets up top-level and syntax-object array + +(define-form-struct form ()) +(define-form-struct (expr form) ()) + +;; A static closure can refer directly to itself, creating a cycle +(define-struct indirect ([v #:mutable]) #:transparent) + +(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this + +;; A provided identifier +(define-form-struct provided ([name symbol?] + [src (or/c module-path-index? #f)] + [src-name symbol?] + [nom-src any/c] ; should be (or/c module-path-index? #f) + [src-phase (or/c 0 1)] + [protected? boolean?] + [insp (or/c boolean? void?)])) + +(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] + [pos exact-nonnegative-integer?] + [const? boolean?] + [ready? boolean?])) ; access binding via prefix array (which is on stack) + +(define-form-struct (seq form) ([forms (listof (or/c form? indirect? any/c))])) ; `begin' + +;; Definitions (top level or within module): +(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? + [rhs (or/c expr? seq? indirect? any/c)])) +(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? + [rhs (or/c expr? seq? indirect? any/c)] + [prefix prefix?] + [max-let-depth exact-nonnegative-integer?])) +(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? + [rhs (or/c expr? seq? indirect? any/c)] + [prefix prefix?] + [max-let-depth exact-nonnegative-integer?])) + +(define-form-struct (mod form) ([name symbol?] + [self-modidx module-path-index?] + [prefix prefix?] + [provides (listof (list/c (or/c exact-integer? #f) + (listof provided?) + (listof provided?)))] + [requires (listof (cons/c (or/c exact-integer? #f) + (listof module-path-index?)))] + [body (listof (or/c form? indirect? any/c))] + [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] + [unexported (list/c (listof symbol?) (listof symbol?) + (listof symbol?))] + [max-let-depth exact-nonnegative-integer?] + [dummy toplevel?] + [lang-info (or/c #f (vector/c module-path? symbol? any/c))] + [internal-context (or/c #f #t stx?)])) + +(define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] + [flags (listof (or/c 'preserves-marks 'is-method 'single-result))] + [num-params integer?] ; should be exact-nonnegative-integer? + [param-types (listof (or/c 'val 'ref 'flonum))] + [rest? boolean?] + [closure-map (vectorof exact-nonnegative-integer?)] + [closure-types (listof (or/c 'val/ref 'flonum))] + [max-let-depth exact-nonnegative-integer?] + [body (or/c expr? seq? indirect? any/c)])) ; `lambda' +(define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) +(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? indirect?))])) ; each clause is a lam (added indirect) + +(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?])) ; pushes one value onto stack +(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? indirect? any/c)])) ; create new stack slots +(define-form-struct (install-value expr) ([count exact-nonnegative-integer?] + [pos exact-nonnegative-integer?] + [boxes? boolean?] + [rhs (or/c expr? seq? indirect? any/c)] + [body (or/c expr? seq? indirect? any/c)])) ; set existing stack slot(s) +(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? indirect? any/c)])) ; put `letrec'-bound closures into existing stack slots +(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? indirect? any/c)])) ; box existing stack element + +(define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack + + +(define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) + +(define-form-struct (application expr) ([rator (or/c expr? seq? indirect? any/c)] [rands (listof (or/c expr? seq? indirect? any/c))])) ; function call +(define-form-struct (branch expr) ([test (or/c expr? seq? indirect? any/c)] [then (or/c expr? seq? indirect? any/c)] [else (or/c expr? seq? indirect? any/c)])) ; `if' +(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? indirect? any/c)] + [val (or/c expr? seq? indirect? any/c)] + [body (or/c expr? seq? indirect? any/c)])) ; `with-continuation-mark' +(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? indirect? any/c))])) ; `begin0' +(define-form-struct (splice form) ([forms (listof (or/c form? indirect? any/c))])) ; top-level `begin' +(define-form-struct (varref expr) ([toplevel toplevel?])) ; `#%variable-reference' +(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? indirect? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! +(define-form-struct (apply-values expr) ([proc (or/c expr? seq? indirect? any/c)] [args-expr (or/c expr? seq? indirect? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive + +;; Top-level `require' +(define-form-struct (req form) ([reqs syntax?] [dummy toplevel?])) + +(define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name + [bool2 boolean?] ; this needs a name + [alist any/c])) ; should be (listof (cons/c symbol? symbol?)) +(define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) +(define-form-struct (wrap-mark wrap) ([val exact-integer?])) +(define-form-struct (prune wrap) ([sym any/c])) + +(define-form-struct all-from-module ([path module-path-index?] + [phase (or/c exact-integer? #f)] + [src-phase any/c] ; should be (or/c exact-integer? #f) + [exceptions list?] ; should be (listof symbol?) + [prefix any/c])) ; should be (or/c symbol? #f) + +(define-form-struct nominal-path ()) +(define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?])) +(define-form-struct (imported-nominal-path nominal-path) ([value module-path-index?] + [import-phase exact-integer?])) +(define-form-struct (phased-nominal-path nominal-path) ([value module-path-index?] + [import-phase exact-integer?] + [phase exact-integer?])) + +(define-form-struct module-binding ()) +(define-form-struct (phased-module-binding module-binding) ([path module-path-index?] + [phase exact-integer?] + [export-name any/c] + [nominal-path nominal-path?] + [nominal-export-name any/c])) +(define-form-struct (exported-nominal-module-binding module-binding) ([path module-path-index?] + [export-name any/c] + [nominal-path nominal-path?] + [nominal-export-name any/c])) +(define-form-struct (nominal-module-binding module-binding) ([path module-path-index?] + [nominal-path nominal-path?])) +(define-form-struct (exported-module-binding module-binding) ([path module-path-index?] + [export-name any/c])) +(define-form-struct (simple-module-binding module-binding) ([path module-path-index?])) + +(define-form-struct (module-rename wrap) ([phase (or/c exact-integer? #f)] + [kind (or/c 'marked 'normal)] + [set-id any/c] + [unmarshals (listof all-from-module?)] + [renames (listof (cons/c symbol? module-binding?))] + [mark-renames any/c] + [plus-kern? boolean?])) + +(provide/contract (struct indirect ([v (or/c closure? #f)]))) + + + + + From 5d8ca3245491f95aca59e6a7db119a192e444ce7 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 17 Feb 2010 23:36:58 +0000 Subject: [PATCH 112/466] compiler/zo-parse: fixed to work on Mac/PPC zo writer seems to always write integers in little-endian order svn: r18141 original commit: f4321256a5efb6e4bde3e9aef2f73e3bdb09aa51 --- collects/compiler/zo-parse.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 8a3daddd2c..c6d1e0b9e3 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -346,7 +346,7 @@ (let loop ([so so]) (if (zero? (bytes-length so)) null - (cons (integer-bytes->integer (subbytes so 0 n) #f) + (cons (integer-bytes->integer (subbytes so 0 n) #f #f) (loop (subbytes so n)))))) (define (read-simple-number p) From f95ba3419231c15f18f1e07962a0f1916c9cf409 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 18 Feb 2010 21:07:05 +0000 Subject: [PATCH 113/466] Adding testing for zo parser/marshaller/decompiler svn: r18155 original commit: fb73b168d1ebfc01de2b282fdc3917024ffe398c --- collects/tests/compiler/zo-test.ss | 338 +++++++++++++++++++++++++++++ 1 file changed, 338 insertions(+) create mode 100644 collects/tests/compiler/zo-test.ss diff --git a/collects/tests/compiler/zo-test.ss b/collects/tests/compiler/zo-test.ss new file mode 100644 index 0000000000..137a7866a0 --- /dev/null +++ b/collects/tests/compiler/zo-test.ss @@ -0,0 +1,338 @@ +#lang scheme +(require compiler/zo-parse + compiler/zo-marshal + compiler/decompile + setup/dirs) + +;; Helpers +(define (bytes-gulp f) + (with-input-from-file f + (λ () (port->bytes (current-input-port))))) +(define (zo-parse/bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (zo-parse ib)) + (lambda () + (close-input-port ib)))) + +(define (bytes-not-equal?-error b1 b2) + (unless (bytes=? b1 b2) + (error 'bytes-not-equal?-error "Not equal"))) + +(define (replace-file file bytes) + (with-output-to-file file + (λ () (write-bytes bytes)) + #:exists 'truncate)) + +(define ((make-recorder! ht) file phase) + (hash-update! ht phase (curry list* file) empty)) + +(define (equal?/why-not v1 v2) + (define (yield p m v1 v2) + (error 'equal?/why-not "~a in ~a: ~S ~S" + m (reverse p) v1 v2)) + (define (inner p v1 v2) + (unless (eq? v1 v2) + (match v1 + [(cons car1 cdr1) + (match v2 + [(cons car2 cdr2) + (inner (list* 'car p) car1 car2) + (inner (list* 'cdr p) cdr1 cdr2)] + [_ + (yield p "Not a cons on right" v1 v2)])] + [(? vector?) + (match v2 + [(? vector?) + (define v1l (vector-length v1)) + (define v2l (vector-length v2)) + (if (= v1l v2l) + (for ([i (in-range v1l)]) + (inner (list* `(vector-ref ,i) p) + (vector-ref v1 i) + (vector-ref v2 i))) + (yield p "Vector lengths not equal" v1 v2))] + [_ + (yield p "Not a vector on right" v1 v2)])] + [(? struct?) + (match v2 + [(? struct?) + (define vv1 (struct->vector v1)) + (define vv2 (struct->vector v2)) + (inner (list* `(struct->vector ,(vector-ref vv1 0)) p) + vv1 vv2)] + [_ + (yield p "Not a struct on right" v1 v2)])] + [(? hash?) + (match v2 + [(? hash?) + (let ([p (list* 'in-hash p)]) + (for ([(k1 hv1) (in-hash v1)]) + (define hv2 + (hash-ref v2 k1 + (lambda () + (yield p (format "~S not in hash on right" k1) v1 v2)))) + (inner (list* `(hash-ref ,k1) p) + hv1 hv2)))] + [_ + (yield p "Not a hash on right" v1 v2)])] + [(? module-path-index?) + (match v2 + [(? module-path-index?) + (define-values (mp1 bmpi1) (module-path-index-split v1)) + (define-values (mp2 bmpi2) (module-path-index-split v2)) + (inner (list* 'module-path-index-split_0 p) mp1 mp2) + (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)] + [_ + (yield p "Not a module path index on right" v1 v2)])] + [(? string?) + (match v2 + [(? string?) + (unless (string=? v1 v2) + (yield p "Unequal strings" v1 v2))] + [_ + (yield p "Not a string on right" v1 v2)])] + [(? path?) + (match v2 + [(? path?) + (unless (equal? v1 v2) + (yield p "Unequal paths" v1 v2))] + [_ + (yield p "Not a path on right" v1 v2)])] + [(? number?) + (match v2 + [(? number?) + (unless (equal? v1 v2) + (yield p "Unequal numbers" v1 v2))] + [_ + (yield p "Not a number on right" v1 v2)])] + [(? symbol?) + (match v2 + [(? symbol?) + (do-compare (symbol-interned? + symbol-unreadable?) + yield p v1 v2 + symbol=?)] + [_ + (yield p "Not a symbol on right" v1 v2)])] + [_ + (yield p "Cannot inspect values deeper" v1 v2)]))) + (inner empty v1 v2)) + +(define-syntax do-compare + (syntax-rules () + [(_ () yield p v1 v2 =) + (unless (= v1 v2) + (yield p (format "Not ~a" '=) v1 v2))] + [(_ (?1 ? ...) yield p v1 v2 =) + (if (?1 v1) + (if (?1 v2) + (do-compare () yield (list* '?1 p) v1 v2 =) + (yield p (format "Not ~a or right" '?1) v1 v2)) + (do-compare (? ...) yield p v1 v2 =))])) + +;; Parameters +(define stop-on-first-error (make-parameter #f)) +(define verbose-mode (make-parameter #f)) +(define care-about-nonserious? (make-parameter #t)) +(define invariant-output (make-parameter #f)) +(define time-limit (make-parameter +inf.0)) +(define randomize (make-parameter #f)) + +;; Work +(define errors (make-hash)) + +(define (common-message exn) + (define given-messages (regexp-match #rx".*given" (exn-message exn))) + (if (and given-messages (not (empty? given-messages))) + (first given-messages) + (exn-message exn))) + +(define (exn-printer file phase serious? exn) + (hash-update! errors (common-message exn) add1 0) + (unless (and (not (care-about-nonserious?)) (not serious?)) + (when (or (verbose-mode) (stop-on-first-error)) + (printf "~a -- ~a: ~a~n" file phase (exn-message exn))) + (when (stop-on-first-error) + exn))) + +(define (run-with-time-limit t thnk) + (define th (thread thnk)) + (sync th + (handle-evt (alarm-evt (+ (current-inexact-milliseconds) + (* 1000 t))) + (lambda _ + (kill-thread th))))) + +(define (run-with-limit file k thnk) + (define file-custodian (make-custodian)) + (define ch (make-channel)) + (custodian-limit-memory file-custodian k) + (local [(define worker-thread + (parameterize ([current-custodian file-custodian]) + (thread + (lambda () + (define r (thnk)) + (channel-put ch r) + (channel-get ch)))))] + (begin0 + (sync + (handle-evt ch + (lambda (v) + (when (exn? v) (raise v)) + v)) + (handle-evt worker-thread + (lambda _ + (failure! file 'memory)))) + (custodian-shutdown-all file-custodian)))) + +(define success-ht (make-hasheq)) +(define success! (make-recorder! success-ht)) +(define failure-ht (make-hasheq)) +(define failure! (make-recorder! failure-ht)) + +(define-syntax run/stages* + (syntax-rules () + [(_ file) (success! file 'everything)] + [(_ file [step1 serious? e] . rst) + (let/ec esc + (let ([step1 (with-handlers ([exn:fail? + (lambda (x) + (failure! file 'step1) + (esc (exn-printer file 'step1 serious? x)))]) + e)]) + (success! file 'step1) + (run/stages* file . rst)))])) + +(define-syntax-rule (define-stages (stages run!) + file + [stage serious? e] ...) + (define-values (stages run!) + (values '(stage ...) + (lambda (file) + (run/stages* file [stage serious? e] ...))))) + +(define-stages (stages run!) + file + [read-orig + #t + (bytes-gulp file)] + [parse-orig + #t + (zo-parse/bytes read-orig)] + [marshal-parsed + #t + (zo-marshal parse-orig)] + #;[ignored + #f + (printf "orig: ~a, marshalled: ~a~n" + (bytes-length read-orig) + (bytes-length marshal-parsed))] + [parse-marshalled + #t + (zo-parse/bytes marshal-parsed)] + [compare-parsed-to-parsed-marshalled + #f + (equal?/why-not parse-orig parse-marshalled)] + [marshal-marshalled + #t + (zo-marshal parse-marshalled)] + [compare-marshalled-to-marshalled-marshalled + #f + (bytes-not-equal?-error marshal-parsed marshal-marshalled)] + #;[replace-with-marshalled + #t + (replace-file file marshal-marshalled)] + [decompile-parsed + #t + (decompile parse-orig)] + [compare-orig-to-marshalled + #f + (bytes-not-equal?-error read-orig marshal-parsed)]) + +(define (run-test file) + (run-with-limit + file + (* 1024 1024 128) + (lambda () + (run! file)))) + +(define (randomize-list l) + (define ll (length l)) + (define seen? (make-hasheq)) + (let loop ([t 0]) + (if (= t ll) + empty + (let ([i (random ll)]) + (if (hash-has-key? seen? i) + (loop t) + (begin (hash-set! seen? i #t) + (list* (list-ref l i) + (loop (add1 t))))))))) + +(define (maybe-randomize-list l) + (if (randomize) (randomize-list l) l)) + +(define (for-zos ! p) + (define p-str (if (path? p) (path->string p) p)) + (cond + [(directory-exists? p) + (for ([sp (in-list (maybe-randomize-list (directory-list p)))]) + (for-zos ! (build-path p sp)))] + [(regexp-match #rx"\\.zo$" p-str) + (! p-str)])) + +(define (zo-test paths) + (run-with-time-limit + (time-limit) + (lambda () + (for-each (curry for-zos run-test) paths))) + + (unless (invariant-output) + (for ([kind-name (list* 'memory stages)]) + (define fails (length (hash-ref failure-ht kind-name empty))) + (define succs (length (hash-ref success-ht kind-name empty))) + (define all (+ fails succs)) + (unless (zero? all) + (printf "~S~n" + `(,kind-name + (#f ,fails) + (#t ,succs) + ,all)))) + (printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty))) + + (printf "Common Errors:~n") + + (for ([p (in-list (sort (filter (λ (p) ((car p) . > . 10)) + (hash-map errors (λ (k v) (cons v k)))) + > #:key car))]) + (printf "~a:~n~a~n~n" (car p) (cdr p))))) + +; Run +#;(current-command-line-arguments #("-s" "/home/bjohn3x/development/plt/collects/browser/compiled/browser_scrbl.zo")) +(command-line #:program "zo-test" + #:once-each + [("-s" "--stop-on-first-error") + "Stop testing when first error is encountered" + (stop-on-first-error #t)] + [("-S") + "Don't take some errors seriously" + (care-about-nonserious? #f)] + [("-v" "--verbose") + "Display verbose error messages" + (verbose-mode #t)] + [("-I") + "Invariant output" + (invariant-output #t)] + [("-R") + "Randomize" + (randomize #t)] + [("-t") + number + "Limit the run to a given amount of time" + (time-limit (string->number number))] + #:args p + (zo-test (if (empty? p) + (list (find-collects-dir)) + p))) \ No newline at end of file From c5b4be68d50cedd553f63cb5c80eface6a441a3a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 19 Feb 2010 19:47:15 +0000 Subject: [PATCH 114/466] Adding comments and specs to parser. Clarifying comments in marshaller. Supporting small numbers, small symbols, small marshalleds, small (proper) lists, small svectors, all-from-module long form Improving inequality detector in tester: regexps and uninterned symbols Correcting doc contract svn: r18194 original commit: 7d1a739df5f06ef32cb865a728b5e46c91d643a1 --- collects/compiler/zo-marshal.ss | 136 +++++++++++++++++++++-------- collects/compiler/zo-parse.ss | 6 ++ collects/tests/compiler/zo-test.ss | 51 +++++++---- 3 files changed, 143 insertions(+), 50 deletions(-) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 4f147dfc67..c59938b482 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -1,6 +1,7 @@ #lang scheme/base (require compiler/zo-structs scheme/match + scheme/local scheme/list scheme/dict) @@ -10,14 +11,9 @@ Less sharing occurs than in the C implementation, creating much larger files - encode-all-from-module only handles one case - - What is the purpose of protect-quote? It was making it so certain things (like paths) weren't being encoded correctly. - + protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off |# -;; Doesn't write as compactly as MzScheme, since list and pair sequences -;; are not compacted, and symbols are not written in short form (define current-wrapped-ht (make-parameter #f)) (define (zo-marshal top) (match top @@ -318,11 +314,30 @@ APPVALS_EXPD SPLICE_EXPD) +(define CPT_SMALL_NUMBER_START 35) +(define CPT_SMALL_NUMBER_END 60) + +(define CPT_SMALL_SYMBOL_START 60) +(define CPT_SMALL_SYMBOL_END 80) + +(define CPT_SMALL_MARSHALLED_START 80) +(define CPT_SMALL_MARSHALLED_END 92) + +(define CPT_SMALL_LIST_MAX 65) +(define CPT_SMALL_PROPER_LIST_START 92) +(define CPT_SMALL_PROPER_LIST_END (+ CPT_SMALL_PROPER_LIST_START CPT_SMALL_LIST_MAX)) + +(define CPT_SMALL_LIST_START CPT_SMALL_PROPER_LIST_END) +(define CPT_SMALL_LIST_END 192) + (define CPT_SMALL_LOCAL_START 192) (define CPT_SMALL_LOCAL_END 207) (define CPT_SMALL_LOCAL_UNBOX_START 207) (define CPT_SMALL_LOCAL_UNBOX_END 222) +(define CPT_SMALL_SVECTOR_START 222) +(define CPT_SMALL_SVECTOR_END 247) + (define CPT_SMALL_APPLICATION_START 247) (define CPT_SMALL_APPLICATION_END 255) @@ -385,8 +400,11 @@ (out-marshaled syntax-type-num (list* key val) out)) (define (out-marshaled type-num val out) - (out-byte CPT_MARSHALLED out) - (out-number type-num out) + (if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START)) + (out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out) + (begin + (out-byte CPT_MARSHALLED out) + (out-number type-num out))) (out-data val out)) (define (out-anything v out) @@ -537,7 +555,9 @@ (define (encode-all-from-module all) (match all [(struct all-from-module (path phase src-phase exceptions prefix)) - (list* path phase src-phase)])) + (if (and (empty? exceptions) (not prefix)) + (list* path phase src-phase) + (list* path phase src-phase (append exceptions prefix)))])) (define (encode-wraps wraps) (for/list ([wrap (in-list wraps)]) @@ -592,7 +612,7 @@ [(struct stx (encoded)) (out-byte CPT_STX out) (out-wrapped encoded out)])))) - + (define (out-form form out) (match form [(? mod?) @@ -734,13 +754,14 @@ (out-expr (protect-quote then) out) (out-expr (protect-quote else) out)] [(struct application (rator rands)) - (if ((length rands) . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) - (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) - (begin - (out-byte CPT_APPLICATION out) - (out-number (length rands) out))) - (for-each (lambda (e) (out-expr (protect-quote e) out)) - (cons rator rands))] + (let ([len (length rands)]) + (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) + (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) + (begin + (out-byte CPT_APPLICATION out) + (out-number len out))) + (for-each (lambda (e) (out-expr (protect-quote e) out)) + (cons rator rands)))] [(struct apply-values (proc args-expr)) (out-syntax APPVALS_EXPD (cons (protect-quote proc) @@ -852,11 +873,15 @@ #f out)] [(symbol? expr) - (out-as-bytes expr - (compose string->bytes/utf-8 symbol->string) - CPT_SYMBOL - #f - out)] + (out-shared expr out + (lambda () + (define bs (string->bytes/utf-8 (symbol->string expr))) + (define len (bytes-length bs)) + (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) + (out-byte (+ CPT_SMALL_SYMBOL_START len) out) + (begin (out-byte CPT_SYMBOL out) + (out-number len out))) + (out-bytes bs out)))] [(keyword? expr) (out-as-bytes expr (compose string->bytes/utf-8 keyword->string) @@ -886,8 +911,12 @@ (out-number (char->integer expr) out)] [(and (exact-integer? expr) (and (expr . >= . -1073741824) (expr . <= . 1073741823))) - (out-byte CPT_INT out) - (out-number expr out)] + (if (and (expr . >= . 0) + (expr . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) + (out-byte (+ CPT_SMALL_NUMBER_START expr) out) + (begin + (out-byte CPT_INT out) + (out-number expr out)))] [(null? expr) (out-byte CPT_NULL out)] [(eq? expr #t) @@ -900,10 +929,46 @@ (out-byte CPT_BOX out) (out-data (unbox expr) out)] [(pair? expr) - (out-byte CPT_LIST out) - (out-number 1 out) - (out-data (car expr) out) - (out-data (cdr expr) out)] + (local [(define seen? (make-hasheq)) ; XXX Maybe this should be global? + (define (list-length-before-cycle/improper-end l) + (if (hash-has-key? seen? l) + (begin (values 0 #f)) + (begin (hash-set! seen? l #t) + (cond + [(null? l) + (values 0 #t)] + [(pair? l) + (let-values ([(len proper?) + (list-length-before-cycle/improper-end (cdr l))]) + (values (add1 len) proper?))] + [else + (values 0 #f)])))) + (define-values (len proper?) (list-length-before-cycle/improper-end expr)) + (define (print-contents-as-proper) + (for ([e (in-list expr)]) + (out-data e out))) + (define (print-contents-as-improper) + (let loop ([l expr] [i len]) + (cond + [(zero? i) + (out-data l out)] + [else + (out-data (car l) out) + (loop (cdr l) (sub1 i))])))] + (if proper? + (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) + (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) + (print-contents-as-proper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-proper) + (out-data null out))) + (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) + (begin (out-byte (+ CPT_SMALL_LIST_START len) out) + (print-contents-as-improper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-improper)))))] [(vector? expr) (out-byte CPT_VECTOR out) (out-number (vector-length expr) out) @@ -921,10 +986,13 @@ (out-data k out) (out-data v out))] [(svector? expr) - (out-byte CPT_SVECTOR out) - (out-number (vector-length (svector-vec expr)) out) - (let ([vec (svector-vec expr)]) - (for ([n (in-range (sub1 (vector-length vec)) -1 -1)]) + (let* ([vec (svector-vec expr)] + [len (vector-length vec)]) + (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) + (out-byte (+ CPT_SMALL_SVECTOR_START len) out) + (begin (out-byte CPT_SVECTOR out) + (out-number len out))) + (for ([n (in-range (sub1 len) -1 -1)]) (out-number (vector-ref vec n) out)))] [(module-path-index? expr) (out-shared expr out @@ -958,8 +1026,8 @@ (define (protect-quote v) v #;(if (or (list? v) (vector? v) (box? v) (hash? v)) - (make-quoted v) - v)) + (make-quoted v) + v)) (define-struct svector (vec)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index c6d1e0b9e3..c130288e49 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -27,6 +27,10 @@ I think parse-module-path-index was only used for debugging, so it is short-circuited now + collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (# 0 (1363072) . #f) --- that doesn't seem to match the spec + + We seem to leave placeholders for hash-tables in the structs + |# ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -598,6 +602,8 @@ (if kind 'marked 'normal) set-id (let ([results (map (lambda (u) + ; u = (list path phase . src-phase) + ; or u = (list path phase src-phase exn ... . prefix) (let ([just-phase? (let ([v (cddr u)]) (or (number? v) (not v)))]) (let-values ([(exns prefix) diff --git a/collects/tests/compiler/zo-test.ss b/collects/tests/compiler/zo-test.ss index 137a7866a0..b2261911bd 100644 --- a/collects/tests/compiler/zo-test.ss +++ b/collects/tests/compiler/zo-test.ss @@ -29,6 +29,9 @@ (hash-update! ht phase (curry list* file) empty)) (define (equal?/why-not v1 v2) + (define v1->v2 (make-hasheq)) + (define (interned-symbol=? s1 s2) + (symbol=? (hash-ref! v1->v2 s1 s2) s2)) (define (yield p m v1 v2) (error 'equal?/why-not "~a in ~a: ~S ~S" m (reverse p) v1 v2)) @@ -93,6 +96,13 @@ (yield p "Unequal strings" v1 v2))] [_ (yield p "Not a string on right" v1 v2)])] + [(? bytes?) + (match v2 + [(? bytes?) + (unless (bytes=? v1 v2) + (yield p "Unequal bytes" v1 v2))] + [_ + (yield p "Not a bytes on right" v1 v2)])] [(? path?) (match v2 [(? path?) @@ -107,30 +117,39 @@ (yield p "Unequal numbers" v1 v2))] [_ (yield p "Not a number on right" v1 v2)])] + [(? regexp?) + (match v2 + [(? regexp?) + (unless (string=? (object-name v1) (object-name v2)) + (yield p "Unequal regexp" v1 v2))] + [_ + (yield p "Not a regexp on right" v1 v2)])] [(? symbol?) (match v2 [(? symbol?) - (do-compare (symbol-interned? - symbol-unreadable?) - yield p v1 v2 - symbol=?)] + (unless (symbol=? v1 v2) + (cond + [(and (symbol-interned? v1) (not (symbol-interned? v1))) + (yield p "Not interned symbol on right" v1 v2)] + [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1))) + (yield p "Not unreadable symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1))) + (yield p "Not uninterned symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (symbol-uninterned? v2)) + (unless (interned-symbol=? v1 v2) + (yield p "Uninterned symbols don't align" v1 v2))] + [else + (yield p "Other symbol-related problem" v1 v2)]))] [_ - (yield p "Not a symbol on right" v1 v2)])] + (yield p "Not a symbol on right" v1 v2)])] + [(? empty?) + (yield p "Not empty on right" v1 v2)] [_ (yield p "Cannot inspect values deeper" v1 v2)]))) (inner empty v1 v2)) -(define-syntax do-compare - (syntax-rules () - [(_ () yield p v1 v2 =) - (unless (= v1 v2) - (yield p (format "Not ~a" '=) v1 v2))] - [(_ (?1 ? ...) yield p v1 v2 =) - (if (?1 v1) - (if (?1 v2) - (do-compare () yield (list* '?1 p) v1 v2 =) - (yield p (format "Not ~a or right" '?1) v1 v2)) - (do-compare (? ...) yield p v1 v2 =))])) +(define (symbol-uninterned? s) + (not (or (symbol-interned? s) (symbol-unreadable? s)))) ;; Parameters (define stop-on-first-error (make-parameter #f)) From 9136b6b85d59392e613fcc06b8255cb63fb6ded9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Mar 2010 01:10:33 +0000 Subject: [PATCH 115/466] chaperones (v4.2.5.3) svn: r18650 original commit: 73807aef247c0d74806fe43ef0720e3979de7007 --- collects/compiler/decompile.ss | 2 +- collects/compiler/zo-marshal.ss | 10 +++++----- collects/compiler/zo-parse.ss | 8 ++++---- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index cff92eccd5..be61752ce8 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -336,7 +336,7 @@ bitwise-bit-set? char=? + - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor arithmetic-shift vector-ref string-ref bytes-ref - set-mcar! set-mcdr! cons mcons + set-mcar! set-mcdr! cons mcons set-box! list list* vector vector-immutable))] [(4) (memq (car a) '(vector-set! string-set! bytes-set! list list* vector vector-immutable diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index c59938b482..2ac973aba1 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -247,11 +247,11 @@ (define wcm-type-num 14) (define quote-syntax-type-num 15) (define variable-type-num 24) -(define top-type-num 87) -(define case-lambda-sequence-type-num 96) -(define begin0-sequence-type-num 97) -(define module-type-num 100) -(define prefix-type-num 102) +(define top-type-num 89) +(define case-lambda-sequence-type-num 99) +(define begin0-sequence-type-num 100) +(define module-type-num 103) +(define prefix-type-num 105) (define-syntax define-enum (syntax-rules () diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 77e6685c95..868d7cbff2 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -314,10 +314,10 @@ [(15) 'quote-syntax-type] [(24) 'variable-type] [(25) 'module-variable-type] - [(96) 'case-lambda-sequence-type] - [(97) 'begin0-sequence-type] - [(100) 'module-type] - [(102) 'resolve-prefix-type] + [(99) 'case-lambda-sequence-type] + [(100) 'begin0-sequence-type] + [(103) 'module-type] + [(105) 'resolve-prefix-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers From 3832a4ae1a57e4d23c6b221543436ea54428c0f9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Apr 2010 15:08:35 +0000 Subject: [PATCH 116/466] rico svn: r18733 original commit: fdba97b1c09d8c338f0d069f17741211917758d5 --- collects/compiler/commands/decompile.ss | 25 +++++++ collects/compiler/commands/exe-dir.ss | 31 ++++++++ collects/compiler/commands/exe.ss | 90 ++++++++++++++++++++++ collects/compiler/commands/expand.ss | 26 +++++++ collects/compiler/commands/info.ss | 10 +++ collects/compiler/commands/make.ss | 79 ++++++++++++++++++++ collects/compiler/commands/pack.ss | 99 +++++++++++++++++++++++++ collects/setup/option-sig.ss | 3 +- 8 files changed, 362 insertions(+), 1 deletion(-) create mode 100644 collects/compiler/commands/decompile.ss create mode 100644 collects/compiler/commands/exe-dir.ss create mode 100644 collects/compiler/commands/exe.ss create mode 100644 collects/compiler/commands/expand.ss create mode 100644 collects/compiler/commands/info.ss create mode 100644 collects/compiler/commands/make.ss create mode 100644 collects/compiler/commands/pack.ss diff --git a/collects/compiler/commands/decompile.ss b/collects/compiler/commands/decompile.ss new file mode 100644 index 0000000000..ee5a4c9eeb --- /dev/null +++ b/collects/compiler/commands/decompile.ss @@ -0,0 +1,25 @@ +#lang scheme/base +(require scheme/cmdline + rico/command-name + compiler/zo-parse + compiler/decompile + scheme/pretty) + +(define source-files + (command-line + #:program (short-program+command-name) + #:args source-or-bytecode-file + source-or-bytecode-file)) + +(for ([zo-file source-files]) + (let ([zo-file (path->complete-path zo-file)]) + (let-values ([(base name dir?) (split-path zo-file)]) + (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))]) + (parameterize ([current-load-relative-directory base] + [print-graph #t]) + (pretty-print + (decompile + (call-with-input-file* + (if (file-exists? alt-file) alt-file zo-file) + (lambda (in) + (zo-parse in)))))))))) diff --git a/collects/compiler/commands/exe-dir.ss b/collects/compiler/commands/exe-dir.ss new file mode 100644 index 0000000000..3952d4d484 --- /dev/null +++ b/collects/compiler/commands/exe-dir.ss @@ -0,0 +1,31 @@ +#lang scheme/base +(require scheme/cmdline + rico/command-name + compiler/distribute) + +(define verbose (make-parameter #f)) +(define exe-embedded-collects-path (make-parameter #f)) +(define exe-dir-add-collects-dirs (make-parameter null)) + +(define-values (dest-dir source-files) + (command-line + #:program (short-program+command-name) + #:once-each + [("--collects-path") path "Set as main collects for executables" + (exe-embedded-collects-path path)] + #:multi + [("++collects-copy") dir "Add collects in to directory" + (exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list dir)))] + #:once-each + [("-v") "Verbose mode" + (verbose #t)] + #:args (dest-dir . executable) + (values dest-dir executable))) + +(assemble-distribution + dest-dir + source-files + #:collects-path (exe-embedded-collects-path) + #:copy-collects (exe-dir-add-collects-dirs)) +(when (verbose) + (printf " [output to \"~a\"]\n" dest-dir)) diff --git a/collects/compiler/commands/exe.ss b/collects/compiler/commands/exe.ss new file mode 100644 index 0000000000..0c5586ab6a --- /dev/null +++ b/collects/compiler/commands/exe.ss @@ -0,0 +1,90 @@ +#lang scheme/base +(require scheme/cmdline + rico/command-name + compiler/private/embed + dynext/file) + +(define verbose (make-parameter #f)) +(define very-verbose (make-parameter #f)) + +(define gui (make-parameter #f)) +(define 3m (make-parameter #t)) + +(define exe-output (make-parameter #f)) +(define exe-embedded-flags (make-parameter '("-U" "--"))) +(define exe-embedded-libraries (make-parameter null)) +(define exe-aux (make-parameter null)) +(define exe-embedded-collects-path (make-parameter #f)) +(define exe-embedded-collects-dest (make-parameter #f)) + +(define source-file + (command-line + #:program (short-program+command-name) + #:once-each + [("-o") file "Write executable as " + (exe-output file)] + [("--gui") "Geneate GUI executable" + (gui #t)] + [("--collects-path") path "Set as main collects for executable" + (exe-embedded-collects-path path)] + [("--collects-dest") dir "Write collection code to " + (exe-embedded-collects-dest dir)] + [("--ico") .ico-file "Set Windows icon for executable" + (exe-aux (cons (cons 'ico .ico-file) (exe-aux)))] + [("--icns") .icns-file "Set Mac OS X icon for executable" + (exe-aux (cons (cons 'icns .icns-file) (exe-aux)))] + [("--orig-exe") "Use original executable instead of stub" + (exe-aux (cons (cons 'original-exe? #t) (exe-aux)))] + [("--3m") "Generate using 3m variant" + (3m #t)] + [("--cgc") "Generate using CGC variant" + (3m #f)] + #:multi + [("++lib") lib "Embed in executable" + (exe-embedded-libraries (append (exe-embedded-libraries) (list lib)))] + [("++exf") flag "Add flag to embed in executable" + (exe-embedded-flags (append (exe-embedded-flags) (list flag)))] + [("--exf") flag "Remove flag to embed in executable" + (exe-embedded-flags (remove flag (exe-embedded-flags)))] + [("--exf-clear") "Clear flags to embed in executable" + (exe-embedded-flags null)] + [("--exf-show") "Show flags to embed in executable" + (printf "Flags to embed: ~s\n" (exe-embedded-flags))] + #:once-each + [("-v") "Verbose mode" + (verbose #t)] + [("--vv") "Very verbose mode" + (verbose #t) + (very-verbose #t)] + #:args (source-file) + source-file)) + +(let ([dest (mzc:embedding-executable-add-suffix + (or (exe-output) + (extract-base-filename/ss source-file + (string->symbol (short-program+command-name)))) + (gui))]) + (mzc:create-embedding-executable + dest + #:mred? (gui) + #:variant (if (3m) '3m 'cgc) + #:verbose? (very-verbose) + #:modules (cons `(#%mzc: (file ,source-file)) + (map (lambda (l) `(#t (lib ,l))) + (exe-embedded-libraries))) + #:configure-via-first-module? #t + #:literal-expression + (parameterize ([current-namespace (make-base-namespace)]) + (compile + `(namespace-require + '',(string->symbol + (format "#%mzc:~a" + (let-values ([(base name dir?) + (split-path source-file)]) + (path->bytes (path-replace-suffix name #"")))))))) + #:cmdline (exe-embedded-flags) + #:collects-path (exe-embedded-collects-path) + #:collects-dest (exe-embedded-collects-dest) + #:aux (exe-aux)) + (when (verbose) + (printf " [output to \"~a\"]\n" dest))) diff --git a/collects/compiler/commands/expand.ss b/collects/compiler/commands/expand.ss new file mode 100644 index 0000000000..45f3539835 --- /dev/null +++ b/collects/compiler/commands/expand.ss @@ -0,0 +1,26 @@ +#lang scheme/base +(require scheme/cmdline + rico/command-name + scheme/pretty) + +(define source-files + (command-line + #:program (short-program+command-name) + #:args source-file + source-file)) + +(for ([src-file source-files]) + (let ([src-file (path->complete-path src-file)]) + (let-values ([(base name dir?) (split-path src-file)]) + (parameterize ([current-load-relative-directory base] + [current-namespace (make-base-namespace)] + [read-accept-reader #t]) + (call-with-input-file* + src-file + (lambda (in) + (port-count-lines! in) + (let loop () + (let ([e (read-syntax src-file in)]) + (unless (eof-object? e) + (pretty-print (syntax->datum (expand e))) + (loop)))))))))) diff --git a/collects/compiler/commands/info.ss b/collects/compiler/commands/info.ss new file mode 100644 index 0000000000..47ac1abd96 --- /dev/null +++ b/collects/compiler/commands/info.ss @@ -0,0 +1,10 @@ +#lang setup/infotab + +(define rico + '(("make" compiler/commands/make "compile source to bytecode" 100) + ("exe" compiler/commands/exe "create executable" 20) + ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) + ("decompile" compiler/commands/decompile "decompile bytecode" #f) + ("expand" compiler/commands/expand "macro-expand source" #f) + ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) + ("c-ext" compiler/commands/c-ext "compile and link C-based extensions" #f))) diff --git a/collects/compiler/commands/make.ss b/collects/compiler/commands/make.ss new file mode 100644 index 0000000000..17d07381f6 --- /dev/null +++ b/collects/compiler/commands/make.ss @@ -0,0 +1,79 @@ +#lang scheme/base +(require scheme/cmdline + rico/command-name + compiler/cm + "../compiler.ss" + dynext/file) + +(define verbose (make-parameter #f)) +(define very-verbose (make-parameter #f)) +(define disable-inlining (make-parameter #f)) + +(define disable-deps (make-parameter #f)) +(define prefixes (make-parameter null)) +(define assume-primitives (make-parameter #t)) + +(define source-files + (command-line + #:program (short-program+command-name) + #:once-each + [("--disable-inline") "Disable procedure inlining during compilation" + (disable-inlining #t)] + [("--no-deps") "Compile immediate files without updating depdencies" + (disable-deps #t)] + [("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps" + (prefixes (append (prefixes) (list file)))] + [("--no-prim") "Do not assume `scheme' bindings at top level for --no-deps" + (assume-primitives #f)] + [("-v") "Verbose mode" + (verbose #t)] + [("--vv") "Very verbose mode" + (verbose #t) + (very-verbose #t)] + #:args file file)) + +(if (disable-deps) + ;; Just compile one file: + (let ([prefix + `(begin + (require scheme) + ,(if (assume-primitives) + '(void) + '(namespace-require/copy 'scheme)) + (require compiler/cffi) + ,@(map (lambda (s) `(load ,s)) (prefixes)) + (void))]) + ((compile-zos prefix #:verbose? (verbose)) + source-files + 'auto)) + ;; Normal make: + (let ([n (make-base-empty-namespace)] + [did-one? #f]) + (parameterize ([current-namespace n] + [manager-trace-handler + (lambda (p) + (when (very-verbose) + (printf " ~a\n" p)))] + [manager-compile-notify-handler + (lambda (p) + (set! did-one? #t) + (when (verbose) + (printf " making ~s\n" (path->string p))))]) + (for ([file source-files]) + (unless (file-exists? file) + (error 'mzc "file does not exist: ~a" file)) + (set! did-one? #f) + (let ([name (extract-base-filename/ss file 'mzc)]) + (when (verbose) + (printf "\"~a\":\n" file)) + (parameterize ([compile-context-preservation-enabled + (disable-inlining)]) + (managed-compile-zo file)) + (let ([dest (append-zo-suffix + (let-values ([(base name dir?) (split-path file)]) + (build-path (if (symbol? base) 'same base) + "compiled" name)))]) + (when (verbose) + (printf " [~a \"~a\"]\n" + (if did-one? "output to" "already up-to-date at") + dest)))))))) diff --git a/collects/compiler/commands/pack.ss b/collects/compiler/commands/pack.ss new file mode 100644 index 0000000000..1605b88d99 --- /dev/null +++ b/collects/compiler/commands/pack.ss @@ -0,0 +1,99 @@ +#lang scheme/base +(require scheme/cmdline + rico/command-name + setup/pack + setup/getinfo + compiler/distribute) + +(define verbose (make-parameter #f)) + +(define collection? (make-parameter #f)) + +(define default-plt-name "archive") + +(define plt-name (make-parameter default-plt-name)) +(define plt-files-replace (make-parameter #f)) +(define plt-files-plt-relative? (make-parameter #f)) +(define plt-files-plt-home-relative? (make-parameter #f)) +(define plt-force-install-dir? (make-parameter #f)) +(define plt-setup-collections (make-parameter null)) +(define plt-include-compiled (make-parameter #f)) + +(define-values (plt-output source-files) + (command-line + #:program (short-program+command-name) + #:once-each + [("--collect") "Pack collections instead of files and directories" + (collection? #t)] + [("--plt-name") name "Set the printed describing the archive" + (plt-name name)] + [("--replace") "Files in archive replace existing files when unpacked" + (plt-files-replace #t)] + [("--at-plt") "Files/dirs in archive are relative to user's add-ons directory" + (plt-files-plt-relative? #t)] + #:once-any + [("--all-users") "Files/dirs in archive go to PLT installation if writable" + (plt-files-plt-home-relative? #t)] + [("--force-all-users") "Files/dirs forced to PLT installation" + (plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)] + #:once-each + [("--include-compiled") "Include \"compiled\" subdirectories in the archive" + (plt-include-compiled #t)] + #:multi + [("++setup") collect "Setup after the archive is unpacked" + (plt-setup-collections (append (plt-setup-collections) (list collect)))] + #:once-each + [("-v") "Verbose mode" + (verbose #t)] + #:args (dest-file . file) + (values dest-file file))) + +(if (not (collection?)) + ;; Files and directories + (begin + (for ([fd source-files]) + (unless (relative-path? fd) + (error 'mzc + "file/directory is not relative to the current directory: \"~a\"" + fd))) + (pack-plt plt-output + (plt-name) + source-files + #:collections (map list (plt-setup-collections)) + #:file-mode (if (plt-files-replace) 'file-replace 'file) + #:plt-relative? (or (plt-files-plt-relative?) + (plt-files-plt-home-relative?)) + #:at-plt-home? (plt-files-plt-home-relative?) + #:test-plt-dirs (if (or (plt-force-install-dir?) + (not (plt-files-plt-home-relative?))) + #f + '("collects" "doc" "include" "lib")) + #:requires + ;; Get current version of mzscheme for require: + (let* ([i (get-info '("mzscheme"))] + [v (and i (i 'version (lambda () #f)))]) + (list (list '("mzscheme") v)))) + (when (verbose) + (printf " [output to \"~a\"]\n" plt-output))) + ;; Collection + (begin + (pack-collections-plt + plt-output + (if (eq? default-plt-name (plt-name)) #f (plt-name)) + (map (lambda (sf) + (let loop ([sf sf]) + (let ([m (regexp-match "^([^/]*)/(.*)$" sf)]) + (if m (cons (cadr m) (loop (caddr m))) (list sf))))) + source-files) + #:replace? (plt-files-replace) + #:extra-setup-collections (map list (plt-setup-collections)) + #:file-filter (if (plt-include-compiled) + (lambda (path) + (or (regexp-match #rx#"compiled$" (path->bytes path)) + (std-filter path))) + std-filter) + #:at-plt-home? (plt-files-plt-home-relative?) + #:test-plt-collects? (not (plt-force-install-dir?))) + (when (verbose) + (printf " [output to \"~a\"]\n" plt-output)))) + diff --git a/collects/setup/option-sig.ss b/collects/setup/option-sig.ss index 79cb5cd4b0..efa4c1eb89 100644 --- a/collects/setup/option-sig.ss +++ b/collects/setup/option-sig.ss @@ -5,7 +5,8 @@ (provide setup-option^) (define-signature setup-option^ - (verbose + (setup-program-name + verbose make-verbose compiler-verbose clean From abd90494f9a0f5b343515a9b187c29d49fd4d7ee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Apr 2010 15:52:36 +0000 Subject: [PATCH 117/466] better compiler handling of unused local bindings where the RHS either doesn't obviously produce a single value or is discovered to be unused late in bytecode compilation; initial Scribble support for printing qq-style results svn: r18737 original commit: c5ac9f23ec5d40ef4d81f69d2dde9932dd38fe77 --- collects/compiler/decompile.ss | 4 ++-- collects/compiler/zo-marshal.ss | 15 ++++++++++----- collects/compiler/zo-parse.ss | 8 +++++--- collects/compiler/zo-structs.ss | 2 +- 4 files changed, 18 insertions(+), 11 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index be61752ce8..c1d5f9cd77 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -207,9 +207,9 @@ ,@(map (lambda (lam) (decompile-lam lam globs stack closed)) lams))] - [(struct let-one (rhs body flonum?)) + [(struct let-one (rhs body flonum? unused?)) (let ([id (or (extract-id rhs) - (gensym 'local))]) + (gensym (if unused? 'unused 'local)))]) `(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)]) (if flonum? (list '#%as-flonum v) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 2ac973aba1..a174d35642 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -160,7 +160,7 @@ [(struct case-lam (name lams)) (traverse-data name visit) (for-each (lambda (lam) (traverse-lam lam visit)) lams)] - [(struct let-one (rhs body flonum?)) + [(struct let-one (rhs body flonum? unused?)) (traverse-expr rhs visit) (traverse-expr body visit)] [(struct let-void (count boxes? body)) @@ -297,7 +297,8 @@ CPT_PATH CPT_CLOSURE CPT_DELAY_REF - CPT_PREFAB) + CPT_PREFAB + CPT_LET_ONE_UNUSED) (define-enum 0 @@ -314,7 +315,7 @@ APPVALS_EXPD SPLICE_EXPD) -(define CPT_SMALL_NUMBER_START 35) +(define CPT_SMALL_NUMBER_START 36) (define CPT_SMALL_NUMBER_END 60) (define CPT_SMALL_SYMBOL_START 60) @@ -715,8 +716,12 @@ (cons (or name null) lams) out)] - [(struct let-one (rhs body flonum?)) - (out-byte (if flonum? CPT_LET_ONE_FLONUM CPT_LET_ONE) out) + [(struct let-one (rhs body flonum? unused?)) + (out-byte (cond + [flonum? CPT_LET_ONE_FLONUM] + [unused? CPT_LET_ONE_UNUSED] + [else CPT_LET_ONE]) + out) (out-expr (protect-quote rhs) out) (out-expr (protect-quote body) out)] [(struct let-void (count boxes? body)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 868d7cbff2..37c3dcd2d6 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -412,7 +412,8 @@ [32 closure] [33 delayed] [34 prefab] - [35 60 small-number] + [35 let-one-unused] + [36 60 small-number] [60 80 small-symbol] [80 92 small-marshalled] [92 ,(+ 92 small-list-max) small-proper-list] @@ -766,9 +767,10 @@ (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) (loop l ppr)))] - [(let-one let-one-flonum) + [(let-one let-one-flonum let-one-unused) (make-let-one (read-compact cp) (read-compact cp) - (eq? cpt-tag 'let-one-flonum))] + (eq? cpt-tag 'let-one-flonum) + (eq? cpt-tag 'let-one-unused))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))] diff --git a/collects/compiler/zo-structs.ss b/collects/compiler/zo-structs.ss index cd37ba4a5a..a1f8f982a8 100644 --- a/collects/compiler/zo-structs.ss +++ b/collects/compiler/zo-structs.ss @@ -118,7 +118,7 @@ (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) (define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? indirect?))])) ; each clause is a lam (added indirect) -(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?])) ; pushes one value onto stack +(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack (define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? indirect? any/c)])) ; create new stack slots (define-form-struct (install-value expr) ([count exact-nonnegative-integer?] [pos exact-nonnegative-integer?] From 6e479fda657d68ae502d9cab61c604098d66b9e5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 15 Apr 2010 21:15:57 -0400 Subject: [PATCH 118/466] create core binaries as 'racket' and 'gracket' original commit: 0f0a59732e9a446aa42c9ab3b43c473ea57e6763 --- collects/launcher/launcher-sig.ss | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/collects/launcher/launcher-sig.ss b/collects/launcher/launcher-sig.ss index 1b5d41289b..25ba8c2bad 100644 --- a/collects/launcher/launcher-sig.ss +++ b/collects/launcher/launcher-sig.ss @@ -1,30 +1,47 @@ - #lang scheme/signature +make-gracket-launcher +make-racket-launcher make-mred-launcher make-mzscheme-launcher +make-gracket-program-launcher +make-racket-program-launcher make-mred-program-launcher make-mzscheme-program-launcher +gracket-program-launcher-path +racket-program-launcher-path mred-program-launcher-path mzscheme-program-launcher-path +install-gracket-program-launcher +install-racket-program-launcher install-mred-program-launcher install-mzscheme-program-launcher +gracket-launcher-up-to-date? +racket-launcher-up-to-date? mred-launcher-up-to-date? mzscheme-launcher-up-to-date? +gracket-launcher-is-directory? +racket-launcher-is-directory? mred-launcher-is-directory? mzscheme-launcher-is-directory? +gracket-launcher-is-actually-directory? +racket-launcher-is-actually-directory? mred-launcher-is-actually-directory? mzscheme-launcher-is-actually-directory? +gracket-launcher-add-suffix +racket-launcher-add-suffix mred-launcher-add-suffix mzscheme-launcher-add-suffix +gracket-launcher-put-file-extension+style+filters +racket-launcher-put-file-extension+style+filters mred-launcher-put-file-extension+style+filters mzscheme-launcher-put-file-extension+style+filters @@ -32,3 +49,5 @@ build-aux-from-path current-launcher-variant available-mred-variants available-mzscheme-variants +available-gracket-variants +available-racket-variants From d898152fa15995dfb0ecfcc7c04974412ef18157 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 21 Apr 2010 13:38:04 -0600 Subject: [PATCH 119/466] rico -> racket-tool original commit: c862eb8121be398c3741b1f68e3b3fbb224d92d9 --- collects/compiler/commands/decompile.ss | 2 +- collects/compiler/commands/exe-dir.ss | 2 +- collects/compiler/commands/exe.ss | 2 +- collects/compiler/commands/expand.ss | 2 +- collects/compiler/commands/info.ss | 2 +- collects/compiler/commands/make.ss | 2 +- collects/compiler/commands/pack.ss | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/compiler/commands/decompile.ss b/collects/compiler/commands/decompile.ss index ee5a4c9eeb..8b16b48434 100644 --- a/collects/compiler/commands/decompile.ss +++ b/collects/compiler/commands/decompile.ss @@ -1,6 +1,6 @@ #lang scheme/base (require scheme/cmdline - rico/command-name + tool/command-name compiler/zo-parse compiler/decompile scheme/pretty) diff --git a/collects/compiler/commands/exe-dir.ss b/collects/compiler/commands/exe-dir.ss index 3952d4d484..95f28d1aee 100644 --- a/collects/compiler/commands/exe-dir.ss +++ b/collects/compiler/commands/exe-dir.ss @@ -1,6 +1,6 @@ #lang scheme/base (require scheme/cmdline - rico/command-name + tool/command-name compiler/distribute) (define verbose (make-parameter #f)) diff --git a/collects/compiler/commands/exe.ss b/collects/compiler/commands/exe.ss index 0c5586ab6a..762df0ff2b 100644 --- a/collects/compiler/commands/exe.ss +++ b/collects/compiler/commands/exe.ss @@ -1,6 +1,6 @@ #lang scheme/base (require scheme/cmdline - rico/command-name + tool/command-name compiler/private/embed dynext/file) diff --git a/collects/compiler/commands/expand.ss b/collects/compiler/commands/expand.ss index 45f3539835..ed742087c1 100644 --- a/collects/compiler/commands/expand.ss +++ b/collects/compiler/commands/expand.ss @@ -1,6 +1,6 @@ #lang scheme/base (require scheme/cmdline - rico/command-name + tool/command-name scheme/pretty) (define source-files diff --git a/collects/compiler/commands/info.ss b/collects/compiler/commands/info.ss index 47ac1abd96..a2fef6dcbd 100644 --- a/collects/compiler/commands/info.ss +++ b/collects/compiler/commands/info.ss @@ -1,6 +1,6 @@ #lang setup/infotab -(define rico +(define racket-tools '(("make" compiler/commands/make "compile source to bytecode" 100) ("exe" compiler/commands/exe "create executable" 20) ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) diff --git a/collects/compiler/commands/make.ss b/collects/compiler/commands/make.ss index 17d07381f6..61336ce1e4 100644 --- a/collects/compiler/commands/make.ss +++ b/collects/compiler/commands/make.ss @@ -1,6 +1,6 @@ #lang scheme/base (require scheme/cmdline - rico/command-name + tool/command-name compiler/cm "../compiler.ss" dynext/file) diff --git a/collects/compiler/commands/pack.ss b/collects/compiler/commands/pack.ss index 1605b88d99..add2f667b1 100644 --- a/collects/compiler/commands/pack.ss +++ b/collects/compiler/commands/pack.ss @@ -1,6 +1,6 @@ #lang scheme/base (require scheme/cmdline - rico/command-name + tool/command-name setup/pack setup/getinfo compiler/distribute) From a42c49472e3d22f8af2d3550b3bbea1290c07ab5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 Apr 2010 18:28:39 -0600 Subject: [PATCH 120/466] move tests/mzscheme to tests/racket original commit: 882b7dce0eaf92eab6fe45565ca6c1a09aa26027 --- collects/tests/{mzscheme => racket}/embed-me1.rkt | 0 collects/tests/{mzscheme => racket}/embed-me10.rkt | 0 collects/tests/{mzscheme => racket}/embed-me11-rd.rkt | 0 collects/tests/{mzscheme => racket}/embed-me1b.rkt | 0 collects/tests/{mzscheme => racket}/embed-me1c.rkt | 0 collects/tests/{mzscheme => racket}/embed-me1d.rkt | 0 collects/tests/{mzscheme => racket}/embed-me1e.rkt | 0 collects/tests/{mzscheme => racket}/embed-me2.rkt | 0 collects/tests/{mzscheme => racket}/embed-me3.rkt | 0 collects/tests/{mzscheme => racket}/embed-me4.rkt | 0 collects/tests/{mzscheme => racket}/embed-me5.rkt | 0 collects/tests/{mzscheme => racket}/embed-me6.rkt | 0 collects/tests/{mzscheme => racket}/embed-me8.c | 0 collects/tests/{mzscheme => racket}/embed-me9.rkt | 0 collects/tests/{mzscheme => racket}/embed.rkt | 0 15 files changed, 0 insertions(+), 0 deletions(-) rename collects/tests/{mzscheme => racket}/embed-me1.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me10.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me11-rd.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me1b.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me1c.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me1d.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me1e.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me2.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me3.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me4.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me5.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me6.rkt (100%) rename collects/tests/{mzscheme => racket}/embed-me8.c (100%) rename collects/tests/{mzscheme => racket}/embed-me9.rkt (100%) rename collects/tests/{mzscheme => racket}/embed.rkt (100%) diff --git a/collects/tests/mzscheme/embed-me1.rkt b/collects/tests/racket/embed-me1.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me1.rkt rename to collects/tests/racket/embed-me1.rkt diff --git a/collects/tests/mzscheme/embed-me10.rkt b/collects/tests/racket/embed-me10.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me10.rkt rename to collects/tests/racket/embed-me10.rkt diff --git a/collects/tests/mzscheme/embed-me11-rd.rkt b/collects/tests/racket/embed-me11-rd.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me11-rd.rkt rename to collects/tests/racket/embed-me11-rd.rkt diff --git a/collects/tests/mzscheme/embed-me1b.rkt b/collects/tests/racket/embed-me1b.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me1b.rkt rename to collects/tests/racket/embed-me1b.rkt diff --git a/collects/tests/mzscheme/embed-me1c.rkt b/collects/tests/racket/embed-me1c.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me1c.rkt rename to collects/tests/racket/embed-me1c.rkt diff --git a/collects/tests/mzscheme/embed-me1d.rkt b/collects/tests/racket/embed-me1d.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me1d.rkt rename to collects/tests/racket/embed-me1d.rkt diff --git a/collects/tests/mzscheme/embed-me1e.rkt b/collects/tests/racket/embed-me1e.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me1e.rkt rename to collects/tests/racket/embed-me1e.rkt diff --git a/collects/tests/mzscheme/embed-me2.rkt b/collects/tests/racket/embed-me2.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me2.rkt rename to collects/tests/racket/embed-me2.rkt diff --git a/collects/tests/mzscheme/embed-me3.rkt b/collects/tests/racket/embed-me3.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me3.rkt rename to collects/tests/racket/embed-me3.rkt diff --git a/collects/tests/mzscheme/embed-me4.rkt b/collects/tests/racket/embed-me4.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me4.rkt rename to collects/tests/racket/embed-me4.rkt diff --git a/collects/tests/mzscheme/embed-me5.rkt b/collects/tests/racket/embed-me5.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me5.rkt rename to collects/tests/racket/embed-me5.rkt diff --git a/collects/tests/mzscheme/embed-me6.rkt b/collects/tests/racket/embed-me6.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me6.rkt rename to collects/tests/racket/embed-me6.rkt diff --git a/collects/tests/mzscheme/embed-me8.c b/collects/tests/racket/embed-me8.c similarity index 100% rename from collects/tests/mzscheme/embed-me8.c rename to collects/tests/racket/embed-me8.c diff --git a/collects/tests/mzscheme/embed-me9.rkt b/collects/tests/racket/embed-me9.rkt similarity index 100% rename from collects/tests/mzscheme/embed-me9.rkt rename to collects/tests/racket/embed-me9.rkt diff --git a/collects/tests/mzscheme/embed.rkt b/collects/tests/racket/embed.rkt similarity index 100% rename from collects/tests/mzscheme/embed.rkt rename to collects/tests/racket/embed.rkt From 28316d52059588b9d31595fa408325c4434ebf79 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Apr 2010 21:55:14 -0600 Subject: [PATCH 121/466] change 'raco c-ext' to 'raco ctool' original commit: 81ba6692375b3f13aa1ab619020a467e6b8a2fd8 --- collects/compiler/commands/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 732470021c..9a3106d696 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -7,4 +7,4 @@ ("decompile" compiler/commands/decompile "decompile bytecode" #f) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) - ("c-ext" compiler/commands/c-ext "compile and link C-based extensions" #f))) + ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f))) From de349463061d3fb164995870bb77f3371cfb425e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 1 May 2010 09:57:07 -0600 Subject: [PATCH 122/466] use .rktl suffix for files meant to be 'load'ed original commit: e504acb72622f4668a50770476fc7545ef9450b0 --- collects/tests/racket/{embed-me4.rkt => embed-me4.rktl} | 0 collects/tests/racket/{embed.rkt => embed.rktl} | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename collects/tests/racket/{embed-me4.rkt => embed-me4.rktl} (100%) rename collects/tests/racket/{embed.rkt => embed.rktl} (99%) diff --git a/collects/tests/racket/embed-me4.rkt b/collects/tests/racket/embed-me4.rktl similarity index 100% rename from collects/tests/racket/embed-me4.rkt rename to collects/tests/racket/embed-me4.rktl diff --git a/collects/tests/racket/embed.rkt b/collects/tests/racket/embed.rktl similarity index 99% rename from collects/tests/racket/embed.rkt rename to collects/tests/racket/embed.rktl index 9b835a68d7..06fd331cb4 100644 --- a/collects/tests/racket/embed.rkt +++ b/collects/tests/racket/embed.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'embed) From c9e6b6cd0ab54eaf02dd874c595598e46f2ed755 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 10 May 2010 06:27:57 -0600 Subject: [PATCH 123/466] have 'raco make' require an argument so that it doesn't silently do nothing when no files are supplied original commit: 68fee973deef0c4e0d66002d012c10a7723662cf --- collects/compiler/commands/make.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 20b8ea9c5f..57ae63c1c4 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -30,7 +30,7 @@ [("--vv") "Very verbose mode" (verbose #t) (very-verbose #t)] - #:args file file)) + #:args (file . another-file) (cons file another-file))) (if (disable-deps) ;; Just compile one file: From 50c18d0b92934aa5305cce9a08197f21ad0bee45 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 16 May 2010 23:46:05 -0400 Subject: [PATCH 124/466] A lot of "MrEd" -> "GRacket"s. original commit: 7f6efdc8beea4b81af31807f9788197c24d0d63e --- collects/tests/racket/embed.rktl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 06fd331cb4..639fe36e10 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -367,7 +367,7 @@ (extension-test #f) (extension-test #t) -;; A MrEd-specific test with mzc: +;; A GRacket-specific test with mzc: (parameterize ([current-directory (find-system-path 'temp-dir)]) (system* mzc "--gui-exe" @@ -375,7 +375,7 @@ (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss"))) (try-exe (mk-dest #t) "This is 5: #\n" #t)) -;; Another MrEd-specific: try embedding plot, which has extra DLLs and font files: +;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: (parameterize ([current-directory (find-system-path 'temp-dir)]) (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) From 46f7907aca969d3b420a6682f90fa5bf0e11bcae Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:48:19 -0600 Subject: [PATCH 125/466] Streaming final output from zo-marshal original commit: b892c276ffebeb35eb3130e5865c312d7fe1f592 --- collects/compiler/zo-marshal.rkt | 43 ++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 0e8276b586..313561f857 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,11 +1,14 @@ #lang scheme/base (require compiler/zo-structs scheme/match + scheme/contract scheme/local scheme/list scheme/dict) -(provide zo-marshal) +(provide/contract + [zo-marshal (compilation-top? . -> . bytes?)] + [zo-marshal-to (compilation-top? output-port? . -> . void?)]) #| Unresolved Issues @@ -16,6 +19,11 @@ (define current-wrapped-ht (make-parameter #f)) (define (zo-marshal top) + (define bs (open-output-bytes)) + (zo-marshal-to top bs) + (get-output-bytes bs)) + +(define (zo-marshal-to top outp) (match top [(struct compilation-top (max-let-depth prefix form)) (let ([encountered (make-hasheq)] @@ -61,24 +69,21 @@ (out-data (list* max-let-depth prefix (protect-quote form)) out) (let ([res (get-output-bytes s)] [version-bs (string->bytes/latin-1 (version))]) - (bytes-append #"#~" - (bytes (bytes-length version-bs)) - version-bs - (int->bytes (add1 (hash-count shared))) - (bytes (if all-short? - 1 - 0)) - (apply - bytes-append - (map (lambda (o) - (integer->integer-bytes o - (if all-short? 2 4) - #f - #f)) - offsets)) - (int->bytes post-shared) - (int->bytes (bytes-length res)) - res))))])) + (write-bytes #"#~" outp) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (write-bytes (bytes (if all-short? + 1 + 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o + (if all-short? 2 4) + #f + #f) outp)) + (write-bytes (int->bytes post-shared) outp) + (write-bytes (int->bytes (bytes-length res)) outp) + (write-bytes res outp))))])) ;; ---------------------------------------- From 4c1a8c83215e2cb026db6ea4ffc876346a97e61b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:55:49 -0600 Subject: [PATCH 126/466] Reformating original commit: 63f546a0808c81191392428e8dd7d1b972fc3f02 --- collects/compiler/zo-marshal.rkt | 111 +++++++++++++++---------------- 1 file changed, 53 insertions(+), 58 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 313561f857..39c06bb90f 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -26,64 +26,59 @@ (define (zo-marshal-to top outp) (match top [(struct compilation-top (max-let-depth prefix form)) - (let ([encountered (make-hasheq)] - [shared (make-hasheq)] - [wrapped (make-hasheq)]) - (let ([visit (lambda (v) - (if (hash-ref shared v #f) - #f - (if (hash-ref encountered v #f) - (begin - (hash-set! shared v (add1 (hash-count shared))) - #f) - (begin - (hash-set! encountered v #t) - (when (closure? v) - (hash-set! shared v (add1 (hash-count shared)))) - #t))))]) - (parameterize ([current-wrapped-ht wrapped]) - (traverse-prefix prefix visit) - (traverse-form form visit))) - (let* ([s (open-output-bytes)] - [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] - [offsets - (map (lambda (v) - (let ([v (cdr v)]) - (begin0 - (file-position s) - (out-anything v (make-out - s - (let ([skip? #t]) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (hash-ref shared v2 #f)))) - wrapped))))) - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car))] - [post-shared (file-position s)] - [all-short? (post-shared . < . #xFFFF)]) - (out-data (list* max-let-depth prefix (protect-quote form)) out) - (let ([res (get-output-bytes s)] - [version-bs (string->bytes/latin-1 (version))]) - (write-bytes #"#~" outp) - (write-bytes (bytes (bytes-length version-bs)) outp) - (write-bytes version-bs outp) - (write-bytes (int->bytes (add1 (hash-count shared))) outp) - (write-bytes (bytes (if all-short? - 1 - 0)) outp) - (for ([o (in-list offsets)]) - (write-bytes (integer->integer-bytes o - (if all-short? 2 4) - #f - #f) outp)) - (write-bytes (int->bytes post-shared) outp) - (write-bytes (int->bytes (bytes-length res)) outp) - (write-bytes res outp))))])) + (define encountered (make-hasheq)) + (define shared (make-hasheq)) + (define wrapped (make-hasheq)) + (define (visit v) + (if (hash-ref shared v #f) + #f + (if (hash-ref encountered v #f) + (begin + (hash-set! shared v (add1 (hash-count shared))) + #f) + (begin + (hash-set! encountered v #t) + (when (closure? v) + (hash-set! shared v (add1 (hash-count shared)))) + #t)))) + (parameterize ([current-wrapped-ht wrapped]) + (traverse-prefix prefix visit) + (traverse-form form visit)) + (let* ([s (open-output-bytes)] + [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] + [offsets + (map (lambda (v) + (let ([v (cdr v)]) + (begin0 + (file-position s) + (out-anything v (make-out + s + (let ([skip? #t]) + (lambda (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (hash-ref shared v2 #f)))) + wrapped))))) + (sort (hash-map shared (lambda (k v) (cons v k))) + < + #:key car))] + [post-shared (file-position s)] + [all-short? (post-shared . < . #xFFFF)] + [version-bs (string->bytes/latin-1 (version))]) + (out-data (list* max-let-depth prefix (protect-quote form)) out) + (let ([res (get-output-bytes s)]) + (write-bytes #"#~" outp) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (write-bytes (bytes (if all-short? 1 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) + (write-bytes (int->bytes post-shared) outp) + (write-bytes (int->bytes (bytes-length res)) outp) + (write-bytes res outp)))])) ;; ---------------------------------------- From 3e79a47bfdac4e9fac41963b999512abb180ec24 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 11:58:55 -0600 Subject: [PATCH 127/466] Reformating original commit: 325ac1ae88644f90e34f51d8090fcebdb36e3a3c --- collects/compiler/zo-marshal.rkt | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 39c06bb90f..7679c97236 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -47,20 +47,20 @@ (let* ([s (open-output-bytes)] [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] [offsets - (map (lambda (v) - (let ([v (cdr v)]) - (begin0 - (file-position s) - (out-anything v (make-out - s - (let ([skip? #t]) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (hash-ref shared v2 #f)))) - wrapped))))) + (map (lambda (k*v) + (define v (cdr k*v)) + (begin0 + (file-position s) + (out-anything v (make-out + s + (let ([skip? #t]) + (lambda (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (hash-ref shared v2 #f)))) + wrapped)))) (sort (hash-map shared (lambda (k v) (cons v k))) < #:key car))] From 2e344d9137f8e52db3081fbd3fb4454386deb559 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 12:45:42 -0600 Subject: [PATCH 128/466] Making zo-marshal more like C and not with large byte strings original commit: 40e1ba95fc6bd592800ec5a565b2bc8eba13c562 --- collects/compiler/zo-marshal.rkt | 75 +++++++++++++++++--------------- 1 file changed, 40 insertions(+), 35 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 7679c97236..5fbf347c94 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,5 +1,6 @@ #lang scheme/base (require compiler/zo-structs + unstable/byte-counting-port scheme/match scheme/contract scheme/local @@ -41,44 +42,48 @@ (when (closure? v) (hash-set! shared v (add1 (hash-count shared)))) #t)))) + (define (v-skipping v) + (define skip? #t) + (lambda (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (hash-ref shared v2 #f)))) (parameterize ([current-wrapped-ht wrapped]) (traverse-prefix prefix visit) (traverse-form form visit)) - (let* ([s (open-output-bytes)] - [out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] - [offsets - (map (lambda (k*v) - (define v (cdr k*v)) - (begin0 - (file-position s) - (out-anything v (make-out - s - (let ([skip? #t]) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (hash-ref shared v2 #f)))) - wrapped)))) - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car))] - [post-shared (file-position s)] - [all-short? (post-shared . < . #xFFFF)] - [version-bs (string->bytes/latin-1 (version))]) - (out-data (list* max-let-depth prefix (protect-quote form)) out) - (let ([res (get-output-bytes s)]) - (write-bytes #"#~" outp) - (write-bytes (bytes (bytes-length version-bs)) outp) - (write-bytes version-bs outp) - (write-bytes (int->bytes (add1 (hash-count shared))) outp) - (write-bytes (bytes (if all-short? 1 0)) outp) - (for ([o (in-list offsets)]) - (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) - (write-bytes (int->bytes post-shared) outp) - (write-bytes (int->bytes (bytes-length res)) outp) - (write-bytes res outp)))])) + (local [(define in-order-shareds + (sort (hash-map shared (lambda (k v) (cons v k))) + < + #:key car)) + (define (write-all outp) + (define offsets + (for/list ([k*v (in-list in-order-shareds)]) + (define v (cdr k*v)) + (begin0 + (file-position outp) + (out-anything v (make-out outp (v-skipping v) wrapped))))) + (define post-shared (file-position outp)) + (out-data (list* max-let-depth prefix (protect-quote form)) + (make-out outp (lambda (v) (hash-ref shared v #f)) wrapped)) + (values offsets post-shared (file-position outp))) + (define counting-p (make-byte-counting-port)) + (define-values (offsets post-shared all-forms-length) + (write-all counting-p)) + (define all-short? (post-shared . < . #xFFFF)) + (define version-bs (string->bytes/latin-1 (version)))] + (write-bytes #"#~" outp) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (write-bytes (bytes (if all-short? 1 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) + (write-bytes (int->bytes post-shared) outp) + (write-bytes (int->bytes all-forms-length) outp) + (write-all outp) + (void))])) ;; ---------------------------------------- From cc82e808352b8446dfb920120d4d38fd2e3216a3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 12:57:32 -0600 Subject: [PATCH 129/466] Separating bytes usage for next change original commit: f67177f7408571c027a8e4040509499c059eb10c --- collects/compiler/zo-parse.rkt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 801430206a..a048f20489 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -361,6 +361,10 @@ (define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis)) +(define (cport-get-bytes cp len) + (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))) +(define (cport-get-byte cp pos) + (bytes-ref (cport-bytes cp) pos)) (define (cport-rpos cp) (+ (cport-pos cp) (cport-shared-start cp))) @@ -369,8 +373,7 @@ (begin-with-definitions (when ((cport-pos cp) . >= . (cport-size cp)) (error "off the end")) - (define r - (bytes-ref (cport-bytes cp) (cport-pos cp))) + (define r (cport-get-byte cp (cport-pos cp))) (set-cport-pos! cp (add1 (cport-pos cp))) r)) @@ -436,7 +439,7 @@ (define (read-compact-bytes port c) (begin0 - (subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c)) + (cport-get-bytes port c) (set-cport-pos! port (+ c (cport-pos port))))) (define (read-compact-chars port c) @@ -742,7 +745,7 @@ v)))] [(escape) (let* ([len (read-compact-number cp)] - [s (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))]) + [s (cport-get-bytes cp len)]) (set-cport-pos! cp (+ (cport-pos cp) len)) (parameterize ([read-accept-compiled #t] [read-accept-bar-quote #t] From f0add80ef2f94ba3cce78fd9f8a65de914bcaf51 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 24 May 2010 13:12:57 -0600 Subject: [PATCH 130/466] Do not read the entire zo at once original commit: 2a934cb0539bc28442b0eaeb91c68afc866f7977 --- collects/compiler/decompile.rkt | 9 +++++---- collects/compiler/zo-parse.rkt | 23 +++++++++++++---------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index e6d8e0aa48..f10d8737ac 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require compiler/zo-parse syntax/modcollapse + scheme/port scheme/match) (provide decompile) @@ -21,10 +22,10 @@ [table (make-hash)]) (for ([b (in-list bindings)]) (let ([v (and (cdr b) - (zo-parse (let-values ([(in out) (make-pipe)]) - (write (cdr b) out) - (close-output-port out) - in)))]) + (zo-parse + (open-input-bytes + (with-output-to-bytes + (λ () (write (cdr b)))))))]) (let ([n (match v [(struct compilation-top (_ prefix (struct primval (n)))) n] [else #f])]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index a048f20489..6f1b338560 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -359,12 +359,16 @@ (define (read-simple-number p) (integer-bytes->integer (read-bytes 4 p) #f #f)) - -(define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis)) +(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets decoded rns mpis)) (define (cport-get-bytes cp len) - (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))) + (define port (cport-orig-port cp)) + (define pos (cport-pos cp)) + (file-position port (+ (cport-bytes-start cp) pos)) + (read-bytes len port)) (define (cport-get-byte cp pos) - (bytes-ref (cport-bytes cp) pos)) + (define port (cport-orig-port cp)) + (file-position port (+ (cport-bytes-start cp) pos)) + (read-byte port)) (define (cport-rpos cp) (+ (cport-pos cp) (cport-shared-start cp))) @@ -979,17 +983,16 @@ (when (shared-size . >= . size*) (error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)")) - (define rst (read-bytes size* port)) + (define rst-start (file-position port)) + + (file-position port (+ rst-start size*)) (unless (eof-object? (read-byte port)) - (error 'not-end)) - - (unless (= size* (bytes-length rst)) - (error "wrong number of bytes")) + (error 'zo-parse "File too big")) (define symtab (make-vector symtabsize (make-not-ready))) - (define cp (make-cport 0 shared-size port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) + (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) (define vv (vector-ref symtab i)) From a6bd87b6322f58e3741f86084c1305485e1f44cc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 12:20:16 -0600 Subject: [PATCH 131/466] Cyclic zo tests original commit: 612bd22bfe88dcfa27d133c6572a42cff406a6dd --- collects/tests/compiler/zo-exs.rkt | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 collects/tests/compiler/zo-exs.rkt diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt new file mode 100644 index 0000000000..b8ab07e067 --- /dev/null +++ b/collects/tests/compiler/zo-exs.rkt @@ -0,0 +1,22 @@ +#lang racket +(require compiler/zo-parse + compiler/zo-marshal + tests/eli-tester) + +(define (roundtrip ct) + (define bs (zo-marshal ct)) + (test bs + (zo-parse (open-input-bytes bs)) => ct)) + +(test + (local [(define (hash-test make-hash-placeholder) + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (local [(define ht-ph (make-placeholder #f)) + (define ht (make-hash-placeholder (list (cons 'g ht-ph))))] + (placeholder-set! ht-ph ht) + (make-reader-graph ht)))))] + (hash-test make-hash-placeholder) + (hash-test make-hasheq-placeholder) + (hash-test make-hasheqv-placeholder))) From cac230bc93c35bec160519212367f3c30cf98f1a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 11:59:41 -0600 Subject: [PATCH 132/466] Unifying some code original commit: 5833f7cba49dcf780684d5144ce152a948231bf9 --- collects/compiler/zo-parse.rkt | 90 ++++++++++++---------------------- 1 file changed, 30 insertions(+), 60 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 6f1b338560..b6596c91b8 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -501,15 +501,9 @@ ;; ---------------------------------------- ;; Syntax unmarshaling - (define (decode-stx cp v) (if (integer? v) - (let-values ([(v2 decoded?) (unmarshal-stx-get cp v)]) - (if decoded? - v2 - (let ([v2 (decode-stx cp v2)]) - (unmarshal-stx-set! cp v v2) - v2))) + (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) (let-values ([(cert-marks v encoded-wraps) (match v @@ -569,24 +563,14 @@ (define (decode-wraps cp w) ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) (if (integer? w) - (let-values ([(w2 decoded?) (unmarshal-stx-get cp w)]) - (if decoded? - w2 - (let ([w2 (decode-wraps cp w2)]) - (unmarshal-stx-set! cp w w2) - w2))) + (unmarshal-stx-get/decode cp w decode-wraps) (map (lambda (a) (let aloop ([a a]) ; A wrap-elem is either (cond ; A reference [(integer? a) - (let-values ([(a2 decoded?) (unmarshal-stx-get cp a)]) - (if decoded? - a2 - (let ([a2 (aloop a2)]) - (unmarshal-stx-set! cp a a2) - a2)))] + (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] ; A mark (not actually a number as the C says, but a (list ) [(and (pair? a) (null? (cdr a)) (number? (car a))) (make-wrap-mark (car a))] @@ -704,22 +688,15 @@ [module-path-index (make-simple-module-binding module-path-index)])))) -(define (unmarshal-stx-get cp pos) - (if (pos . >= . (vector-length (cport-symtab cp))) - (values `(#%bad-index ,pos) #t) - (let ([v (vector-ref (cport-symtab cp) pos)]) - (if (not-ready? v) - (let ([save-pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) - (let ([v (read-compact cp)]) - (vector-set! (cport-symtab cp) pos v) - (set-cport-pos! cp save-pos) - (values v #f))) - (values v (vector-ref (cport-decoded cp) pos)))))) - -(define (unmarshal-stx-set! cp pos v) - (vector-set! (cport-symtab cp) pos v) - (vector-set! (cport-decoded cp) pos #t)) +(define (unmarshal-stx-get/decode cp pos decode-stx) + (define v2 (read-sym cp pos)) + (define decoded? (vector-ref (cport-decoded cp) pos)) + (if decoded? + v2 + (let ([dv2 (decode-stx cp v2)]) + (vector-set! (cport-symtab cp) pos dv2) + (vector-set! (cport-decoded cp) pos #t) + dv2))) (define (parse-module-path-index cp s) s) @@ -738,15 +715,7 @@ (case cpt-tag [(delayed) (let ([pos (read-compact-number cp)]) - (let ([v (vector-ref (cport-symtab cp) pos)]) - (if (not-ready? v) - (let ([save-pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) - (let ([v (read-compact cp)]) - (vector-set! (cport-symtab cp) pos v) - (set-cport-pos! cp save-pos) - v)) - v)))] + (read-sym cp pos))] [(escape) (let* ([len (read-compact-number cp)] [s (cport-get-bytes cp len)]) @@ -894,16 +863,8 @@ (read-compact cp))))]) (read (open-input-bytes #"x")))))] [(symref) - (let* ([l (read-compact-number cp)] - [v (vector-ref (cport-symtab cp) l)]) - (if (not-ready? v) - (let ([pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l))) - (let ([v (read-compact cp)]) - (set-cport-pos! cp pos) - (vector-set! (cport-symtab cp) l v) - v)) - v))] + (let* ([l (read-compact-number cp)]) + (read-sym cp l))] [(weird-symbol) (let ([uninterned (read-compact-number cp)] [str (read-compact-chars cp (read-compact-number cp))]) @@ -956,6 +917,17 @@ [else (cons v (loop (sub1 need-car) proper))])))) +(define (read-sym cp i) + (define symtab (cport-symtab cp)) + (define vv (vector-ref symtab i)) + (define save-pos (cport-pos cp)) + (when (not-ready? vv) + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) + (let ([v (read-compact cp)]) + (vector-set! symtab i v)) + (set-cport-pos! cp save-pos)) + (vector-ref symtab i)) + ;; path -> bytes ;; implementes read.c:read_compiled (define (zo-parse port) @@ -990,16 +962,14 @@ (unless (eof-object? (read-byte port)) (error 'zo-parse "File too big")) - (define symtab (make-vector symtabsize (make-not-ready))) + (define nr (make-not-ready)) + (define symtab + (make-vector symtabsize nr)) (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) - (define vv (vector-ref symtab i)) - (when (not-ready? vv) - (set-cport-pos! cp (vector-ref so* (sub1 i))) - (let ([v (read-compact cp)]) - (vector-set! symtab i v)))) + (read-sym cp i)) (set-cport-pos! cp shared-size) (read-marshalled 'compilation-top-type cp))) From 2fd33535084366b88ae721a5e15e932bcb172480 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 11:59:55 -0600 Subject: [PATCH 133/466] Dealing with cyclic hashes original commit: 40884483176778b26d6444100d1c997b9e8961cd --- collects/compiler/zo-marshal.rkt | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 5fbf347c94..f3ee228f9d 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -228,6 +228,11 @@ (traverse-stx expr visit)] [(wrapped? expr) (traverse-wrapped expr visit)] + [(hash? expr) + (when (visit expr) + (for ([(k v) (in-hash expr)]) + (traverse-data k visit) + (traverse-data v visit)))] [else (void)])) @@ -987,16 +992,18 @@ (for ([v (in-vector expr)]) (out-data v out))] [(hash? expr) - (out-byte CPT_HASH_TABLE out) - (out-number (cond - [(hash-eqv? expr) 2] - [(hash-eq? expr) 0] - [else 1]) - out) - (out-number (hash-count expr) out) - (for ([(k v) (in-hash expr)]) - (out-data k out) - (out-data v out))] + (out-shared expr out + (lambda () + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? expr) 2] + [(hash-eq? expr) 0] + [else 1]) + out) + (out-number (hash-count expr) out) + (for ([(k v) (in-hash expr)]) + (out-data k out) + (out-data v out))))] [(svector? expr) (let* ([vec (svector-vec expr)] [len (vector-length vec)]) From 7b264d5089735241cca597ab6db009029733e971 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 12:13:13 -0600 Subject: [PATCH 134/466] Using placeholders in zo-parse for more cyclic datums original commit: 035ee93911901636d7dc87a83e991dd4290386e5 --- collects/compiler/zo-parse.rkt | 58 +++++++++++++++++--------------- collects/compiler/zo-structs.rkt | 4 +-- 2 files changed, 33 insertions(+), 29 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index b6596c91b8..4d97023a90 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -15,8 +15,6 @@ Lines 628, 630 seem to be only for debugging and should probably throw errors - unmarshal-stx-get also seems to be for debugging and should probably throw an error - vector and pair cases of decode-wraps seem to do different things from the corresponding C code Line 816: This should be an eqv placeholder (but they don't exist) @@ -29,8 +27,6 @@ collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (# 0 (1363072) . #f) --- that doesn't seem to match the spec - We seem to leave placeholders for hash-tables in the structs - |# ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -558,8 +554,6 @@ (map loop (cdr (vector->list (struct->vector v)))))))] [else (add-wrap v)])))))) - - (define (decode-wraps cp w) ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) (if (integer? w) @@ -688,16 +682,6 @@ [module-path-index (make-simple-module-binding module-path-index)])))) -(define (unmarshal-stx-get/decode cp pos decode-stx) - (define v2 (read-sym cp pos)) - (define decoded? (vector-ref (cport-decoded cp) pos)) - (if decoded? - v2 - (let ([dv2 (decode-stx cp v2)]) - (vector-set! (cport-symtab cp) pos dv2) - (vector-set! (cport-decoded cp) pos #t) - dv2))) - (define (parse-module-path-index cp s) s) ;; ---------------------------------------- @@ -895,7 +879,7 @@ [(closure) (let* ([l (read-compact-number cp)] [ind (make-indirect #f)]) - (vector-set! (cport-symtab cp) l ind) + (placeholder-set! (vector-ref (cport-symtab cp) l) ind) (let* ([v (read-compact cp)] [cl (make-closure v (gensym (let ([s (lam-name v)]) @@ -917,16 +901,35 @@ [else (cons v (loop (sub1 need-car) proper))])))) +(define (unmarshal-stx-get/decode cp pos decode-stx) + (define v2 (read-sym cp pos)) + (define decoded? (vector-ref (cport-decoded cp) pos)) + (if decoded? + v2 + (let ([dv2 (decode-stx cp v2)]) + (placeholder-set! (vector-ref (cport-symtab cp) pos) dv2) + (vector-set! (cport-decoded cp) pos #t) + dv2))) + +(require unstable/markparam) +(define read-sym-mark (mark-parameter)) (define (read-sym cp i) (define symtab (cport-symtab cp)) - (define vv (vector-ref symtab i)) - (define save-pos (cport-pos cp)) - (when (not-ready? vv) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) - (let ([v (read-compact cp)]) - (vector-set! symtab i v)) - (set-cport-pos! cp save-pos)) - (vector-ref symtab i)) + (define ph (vector-ref symtab i)) + ; We are reading this already, so return the placeholder + (if (memq i (mark-parameter-all read-sym-mark)) + ph + ; Otherwise, try to read it and return the real thing + (local [(define vv (placeholder-get ph))] + (when (not-ready? vv) + (local [(define save-pos (cport-pos cp))] + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) + (mark-parameterize + ([read-sym-mark i]) + (let ([v (read-compact cp)]) + (placeholder-set! ph v))) + (set-cport-pos! cp save-pos))) + (placeholder-get ph)))) ;; path -> bytes ;; implementes read.c:read_compiled @@ -964,14 +967,15 @@ (define nr (make-not-ready)) (define symtab - (make-vector symtabsize nr)) + (build-vector symtabsize (λ (i) (make-placeholder nr)))) (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) (read-sym cp i)) (set-cport-pos! cp shared-size) - (read-marshalled 'compilation-top-type cp))) + (make-reader-graph + (read-marshalled 'compilation-top-type cp)))) ;; ---------------------------------------- diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 2d2413594d..7c3e317bd4 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -22,7 +22,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin - (define-struct id+par (field-id ...) #:transparent) + (define-struct id+par (field-id ...) #:prefab) (provide/contract [struct id ([field-id field-contract] ...)]))) @@ -57,7 +57,7 @@ (define-form-struct (expr form) ()) ;; A static closure can refer directly to itself, creating a cycle -(define-struct indirect ([v #:mutable]) #:transparent) +(define-struct indirect ([v #:mutable]) #:prefab) (define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this From 304e5247ed2b59ca1b85d1423861e6e59c29f5ad Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 27 May 2010 12:19:58 -0600 Subject: [PATCH 135/466] Documenting make-hasheqv and using it original commit: 7e485b8d28a43581c501c0f16e62e7b67f494324 --- collects/compiler/zo-parse.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 4d97023a90..c7f6670fc3 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -794,9 +794,8 @@ [len (read-compact-number cp)]) ((case eq [(0) make-hasheq-placeholder] - ; XXX One of these should be eqv [(1) make-hash-placeholder] - [(2) make-hash-placeholder]) + [(2) make-hasheqv-placeholder]) (for/list ([i (in-range len)]) (cons (read-compact cp) (read-compact cp)))))] From d19d9eb8f76cf2269d667693be09e3668bbb5c87 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 10 Jun 2010 07:31:53 -0400 Subject: [PATCH 136/466] tweak decompiler to use a different name for boxed locals original commit: 535c8e0a09a2bb9ed34881ed19f81763226c9d12 --- collects/compiler/decompile.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index f10d8737ac..b011c988ab 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -221,7 +221,7 @@ (extract-ids! body ids) (let ([vars (for/list ([i (in-range count)] [id (in-vector ids)]) - (or id (gensym 'localv)))]) + (or id (gensym (if boxes? 'localvb 'localv))))]) `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) vars) ,(decompile-expr body globs (append vars stack) closed))))] From aa49f6b2dee4ed3e77901e3ac5049186ba7526a2 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 15 Jun 2010 12:45:51 -0400 Subject: [PATCH 137/466] Added an empty benchmark to measure Typed Scheme's startup time. original commit: 31d4da6f399acdd6f3f7217594d1f6ae2a7893c2 --- collects/tests/racket/benchmarks/shootout/nothing.rkt | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 collects/tests/racket/benchmarks/shootout/nothing.rkt diff --git a/collects/tests/racket/benchmarks/shootout/nothing.rkt b/collects/tests/racket/benchmarks/shootout/nothing.rkt new file mode 100644 index 0000000000..e5a3b58314 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/nothing.rkt @@ -0,0 +1,2 @@ +#lang racket/base +1 From 405f94f6fc536e05000ddd4a419991c1f700850e Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 30 Jun 2010 14:00:09 -0600 Subject: [PATCH 138/466] unstable: removed byte-counting-port.rkt (use open-output-nowhere instead) updated test to verify that open-output-nowhere has same behavior original commit: a543c2137e25931706eca97282541785b75660bf --- collects/compiler/zo-marshal.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index f3ee228f9d..fba002eecb 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,6 +1,6 @@ #lang scheme/base (require compiler/zo-structs - unstable/byte-counting-port + scheme/port scheme/match scheme/contract scheme/local @@ -68,7 +68,7 @@ (out-data (list* max-let-depth prefix (protect-quote form)) (make-out outp (lambda (v) (hash-ref shared v #f)) wrapped)) (values offsets post-shared (file-position outp))) - (define counting-p (make-byte-counting-port)) + (define counting-p (open-output-nowhere)) (define-values (offsets post-shared all-forms-length) (write-all counting-p)) (define all-short? (post-shared . < . #xFFFF)) From 4fc9ef63169790af053e0b3d56689ed79e2ab4de Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 6 Jul 2010 10:01:29 -0600 Subject: [PATCH 139/466] [Parallel-Build] remove -u, -j 1 is uniprocessor, SETUP_OPTIONTS => PLT_SETUP_OPTIONS original commit: c9e84f9f672f56ddb6b837483b359af2f4879a08 --- collects/setup/option-sig.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/setup/option-sig.rkt b/collects/setup/option-sig.rkt index cad8bedaa7..00e9f426bd 100644 --- a/collects/setup/option-sig.rkt +++ b/collects/setup/option-sig.rkt @@ -21,7 +21,6 @@ call-install call-post-install pause-on-errors - parallel-build parallel-workers force-unpacks doc-pdf-dest From 2cd7824462a4df9be38c066ece9ae48acddd04f8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Jul 2010 06:18:34 -0600 Subject: [PATCH 140/466] fix docs on `raco make --no-deps' Closes PR 11018 original commit: a8062dc37d835939196e7c38e59cc8eae3d15d5c --- collects/compiler/commands/make.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 57ae63c1c4..5cfd96af01 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -19,7 +19,7 @@ #:once-each [("--disable-inline") "Disable procedure inlining during compilation" (disable-inlining #t)] - [("--no-deps") "Compile immediate files without updating depdencies" + [("--no-deps") "Compile immediate files without updating dependencies" (disable-deps #t)] [("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps" (prefixes (append (prefixes) (list file)))] From d35c8cac36b678d272341fb53ed0bba5d691cbc7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 8 Jul 2010 16:51:47 -0600 Subject: [PATCH 141/466] fix validation of module .zo exp-time content, and fix zo-marshal original commit: c7c8f56e111f1948242327e71b5c4ce8becd2922 --- collects/compiler/zo-marshal.rkt | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index fba002eecb..0ff5989dfb 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -479,7 +479,18 @@ [l (cons (lookup-req 1) l)] ; et-requires [l (cons (lookup-req 0) l)] ; requires [l (cons (list->vector body) l)] - [l (cons (list->vector syntax-body) l)] + [l (cons (list->vector + (for/list ([i (in-list syntax-body)]) + (define (maybe-one l) ;; a single symbol is ok + (if (and (pair? l) (null? (cdr l))) + (car l) + l)) + (match i + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (vector (maybe-one ids) rhs max-let-depth prefix #f)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) + l)] [l (append (apply append (map (lambda (l) From 5b322e2bd7073450017a46eccd53d9fda3a73952 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 9 Jul 2010 09:48:41 -0600 Subject: [PATCH 142/466] fix `planet'-path bug in module-name resolver for generated eecutables original commit: 195b37831b802472a24d01df1a629ee465835af6 --- collects/tests/racket/embed-planet-1/alt.rkt | 6 + collects/tests/racket/embed-planet-1/main.rkt | 4 + .../tests/racket/embed-planet-1/other.rkt | 6 + collects/tests/racket/embed-planet-2/main.ss | 5 + .../racket/embed-planet-2/private/sub.rkt | 6 + collects/tests/racket/embed.rktl | 131 +++++++++++++----- 6 files changed, 121 insertions(+), 37 deletions(-) create mode 100644 collects/tests/racket/embed-planet-1/alt.rkt create mode 100644 collects/tests/racket/embed-planet-1/main.rkt create mode 100644 collects/tests/racket/embed-planet-1/other.rkt create mode 100644 collects/tests/racket/embed-planet-2/main.ss create mode 100644 collects/tests/racket/embed-planet-2/private/sub.rkt diff --git a/collects/tests/racket/embed-planet-1/alt.rkt b/collects/tests/racket/embed-planet-1/alt.rkt new file mode 100644 index 0000000000..197192d70e --- /dev/null +++ b/collects/tests/racket/embed-planet-1/alt.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "main.ss") + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln "alt"))) diff --git a/collects/tests/racket/embed-planet-1/main.rkt b/collects/tests/racket/embed-planet-1/main.rkt new file mode 100644 index 0000000000..c2ec8174a1 --- /dev/null +++ b/collects/tests/racket/embed-planet-1/main.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(with-output-to-file "stdout" + (lambda () (displayln "one"))) diff --git a/collects/tests/racket/embed-planet-1/other.rkt b/collects/tests/racket/embed-planet-1/other.rkt new file mode 100644 index 0000000000..98b95b7a4e --- /dev/null +++ b/collects/tests/racket/embed-planet-1/other.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require (planet racket-tester/p2)) + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln "other"))) diff --git a/collects/tests/racket/embed-planet-2/main.ss b/collects/tests/racket/embed-planet-2/main.ss new file mode 100644 index 0000000000..818ed55316 --- /dev/null +++ b/collects/tests/racket/embed-planet-2/main.ss @@ -0,0 +1,5 @@ +#lang racket/base + + +(with-output-to-file "stdout" + (lambda () (displayln "two"))) diff --git a/collects/tests/racket/embed-planet-2/private/sub.rkt b/collects/tests/racket/embed-planet-2/private/sub.rkt new file mode 100644 index 0000000000..120caf0483 --- /dev/null +++ b/collects/tests/racket/embed-planet-2/private/sub.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "../main.ss") + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln "sub"))) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 19c392502d..25036d3566 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -234,18 +234,19 @@ `(,(flags "ne") "(out \"\u7237...\U1D671\n\")")) (try-exe dest "\uA9, \u7238, and \U1D670\n\u7237...\U1D671\n" mred?)) -(mz-tests #f) -(mz-tests #t) +(define (try-basic) + (mz-tests #f) + (mz-tests #t) -(begin - (prepare mr-dest "embed-me5.rkt") - (make-embedding-executable - mr-dest #t #f - `((#t (lib "embed-me5.rkt" "tests" "racket"))) - null - #f - `("-l" "tests/racket/embed-me5.rkt")) - (try-exe mr-dest "This is 5: #\n" #t)) + (begin + (prepare mr-dest "embed-me5.rkt") + (make-embedding-executable + mr-dest #t #f + `((#t (lib "embed-me5.rkt" "tests" "racket"))) + null + #f + `("-l" "tests/racket/embed-me5.rkt")) + (try-exe mr-dest "This is 5: #\n" #t))) ;; Try the mzc interface: (require setup/dirs @@ -306,8 +307,9 @@ (void))) -(mzc-tests #f) -(mzc-tests #t) +(define (try-mzc) + (mzc-tests #f) + (mzc-tests #t)) (require dynext/file) (define (extension-test mred?) @@ -364,32 +366,34 @@ (path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt"))) (try-exe (mk-dest mred?) "#t\n" mred?))) -(extension-test #f) -(extension-test #t) +(define (try-extension) + (extension-test #f) + (extension-test #t)) -;; A GRacket-specific test with mzc: -(parameterize ([current-directory (find-system-path 'temp-dir)]) - (system* mzc - "--gui-exe" - (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) - (try-exe (mk-dest #t) "This is 5: #\n" #t)) +(define (try-gracket) + ;; A GRacket-specific test with mzc: + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (system* mzc + "--gui-exe" + (path->string (mk-dest #t)) + (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) + (try-exe (mk-dest #t) "This is 5: #\n" #t)) -;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: -(parameterize ([current-directory (find-system-path 'temp-dir)]) - (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) + ;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) - (test #t - system* (build-path (find-console-bin-dir) "mred") - "-qu" - (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) - (path->string direct)) + (test #t + system* (build-path (find-console-bin-dir) "mred") + "-qu" + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) + (path->string direct)) - (system* mzc - "--gui-exe" - (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) - (try-exe (mk-dest #t) "plotted\n" #t)) + (system* mzc + "--gui-exe" + (path->string (mk-dest #t)) + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) + (try-exe (mk-dest #t) "plotted\n" #t))) ;; Try including source that needs a reader extension @@ -417,7 +421,60 @@ (try-exe dest "It goes to eleven!\n" mred?) (putenv "ELEVEN" "done")) -(try-reader-test #f) -(try-reader-test #t) +(define (try-reader) + (try-reader-test #f) + (try-reader-test #t)) + +;; ---------------------------------------- + +(define planet (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) + "planet.exe" + "planet"))) + +(define (try-planet) + (system* planet "link" "racket-tester" "p1.plt" "1" "0" + (path->string (collection-path "tests" "racket" "embed-planet-1"))) + (system* planet "link" "racket-tester" "p2.plt" "2" "2" + (path->string (collection-path "tests" "racket" "embed-planet-2"))) + + (let ([go (lambda (path expected) + (printf "Trying planet ~s...\n" path) + (let ([tmp (make-temporary-file)] + [dest (mk-dest #f)]) + (with-output-to-file tmp + #:exists 'truncate + (lambda () + (printf "#lang racket/base (require ~s)\n" path))) + (system* mzc "--exe" (path->string dest) (path->string tmp)) + (try-exe dest expected #f) + + (delete-directory/files dest) + + (delete-file tmp)))]) + (go '(planet racket-tester/p1) "one\n") + (go '(planet "racket-tester/p1:1") "one\n") + (go '(planet "racket-tester/p1:1:0") "one\n") + (go '(planet "racket-tester/p1:1:0/main.ss") "one\n") + (go '(planet racket-tester/p2) "two\n") + + (go '(planet racket-tester/p1/alt) "one\nalt\n") + (go '(planet racket-tester/p1/other) "two\nother\n") + (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + + (void)) + + (system* planet "unlink" "racket-tester" "p1.plt" "1" "0") + (system* planet "unlink" "racket-tester" "p2.plt" "2" "2")) + +;; ---------------------------------------- + +(try-basic) +(try-mzc) +(try-extension) +(try-gracket) +(try-reader) +(try-planet) + +;; ---------------------------------------- (report-errs) From 6887ead2c595e41a7f8165a12d4763bb0ceb256c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 15 Jul 2010 15:35:54 -0600 Subject: [PATCH 143/466] handling top-level-renames and mark-barriers original commit: 8df94dd746b2a3b08e21f1a07730165294dc6821 --- collects/compiler/zo-marshal.rkt | 4 ++++ collects/compiler/zo-parse.rkt | 4 ++-- collects/compiler/zo-structs.rkt | 9 ++++++++- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 0ff5989dfb..8333ef8c23 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -609,6 +609,10 @@ (vector-set! vec (+ 2 i) k) (vector-set! vec (+ 2 i len) v)) vec] + [(struct top-level-rename (flag)) + flag] + [(struct mark-barrier (value)) + value] [(struct prune (syms)) (box syms)] [(struct wrap-mark (val)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 46ad7d584f..7c1186ed64 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -624,9 +624,9 @@ (and plus-kern? 'plus-kern)))] [else (error "bad module rename: ~e" a)]))] [(boolean? a) - `(#%top-level-rename ,a)] + (make-top-level-rename a)] [(symbol? a) - '(#%mark-barrier)] + (make-mark-barrier a)] [(box? a) (match (unbox a) [(list (? symbol?) ...) (make-prune (unbox a))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 7c3e317bd4..daba19df57 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -23,6 +23,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin (define-struct id+par (field-id ...) #:prefab) + #;(provide (struct-out id)) (provide/contract [struct id ([field-id field-contract] ...)]))) @@ -147,7 +148,7 @@ (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive ;; Top-level `require' -(define-form-struct (req form) ([reqs syntax?] [dummy toplevel?])) +(define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) (define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name [bool2 boolean?] ; this needs a name @@ -194,6 +195,12 @@ [mark-renames any/c] [plus-kern? boolean?])) +; XXX better name for 'flag' +(define-form-struct (top-level-rename wrap) ([flag boolean?])) + +; XXX better name for 'value' +(define-form-struct (mark-barrier wrap) ([value symbol?])) + (provide/contract (struct indirect ([v (or/c closure? #f)]))) From 1325701f829f0d04c2550e57ee4e28ee01c55f83 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 15 Jul 2010 15:35:54 -0600 Subject: [PATCH 144/466] handling top-level-renames and mark-barriers (cherry picked from commit 8df94dd746b2a3b08e21f1a07730165294dc6821) original commit: 06c829d8c0e482abd1fbb534a9999c1f21aa1ac0 --- collects/compiler/zo-marshal.rkt | 4 ++++ collects/compiler/zo-parse.rkt | 4 ++-- collects/compiler/zo-structs.rkt | 9 ++++++++- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 0ff5989dfb..8333ef8c23 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -609,6 +609,10 @@ (vector-set! vec (+ 2 i) k) (vector-set! vec (+ 2 i len) v)) vec] + [(struct top-level-rename (flag)) + flag] + [(struct mark-barrier (value)) + value] [(struct prune (syms)) (box syms)] [(struct wrap-mark (val)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 46ad7d584f..7c1186ed64 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -624,9 +624,9 @@ (and plus-kern? 'plus-kern)))] [else (error "bad module rename: ~e" a)]))] [(boolean? a) - `(#%top-level-rename ,a)] + (make-top-level-rename a)] [(symbol? a) - '(#%mark-barrier)] + (make-mark-barrier a)] [(box? a) (match (unbox a) [(list (? symbol?) ...) (make-prune (unbox a))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 7c3e317bd4..daba19df57 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -23,6 +23,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin (define-struct id+par (field-id ...) #:prefab) + #;(provide (struct-out id)) (provide/contract [struct id ([field-id field-contract] ...)]))) @@ -147,7 +148,7 @@ (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive ;; Top-level `require' -(define-form-struct (req form) ([reqs syntax?] [dummy toplevel?])) +(define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) (define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name [bool2 boolean?] ; this needs a name @@ -194,6 +195,12 @@ [mark-renames any/c] [plus-kern? boolean?])) +; XXX better name for 'flag' +(define-form-struct (top-level-rename wrap) ([flag boolean?])) + +; XXX better name for 'value' +(define-form-struct (mark-barrier wrap) ([value symbol?])) + (provide/contract (struct indirect ([v (or/c closure? #f)]))) From 3128c026413e846e934c6d0110723cc4e92417d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 19 Jul 2010 13:55:23 -0600 Subject: [PATCH 145/466] raco exe: fix missing ss->rkt conversion and remove debugging printf Merge to 5.0.1 original commit: f602d11a7f77fb8cd14d11698150a8240a7d4b3f --- collects/tests/racket/embed.rktl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 25036d3566..16a4e71a87 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -460,6 +460,7 @@ (go '(planet racket-tester/p1/alt) "one\nalt\n") (go '(planet racket-tester/p1/other) "two\nother\n") (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (void)) @@ -468,11 +469,11 @@ ;; ---------------------------------------- -(try-basic) -(try-mzc) -(try-extension) -(try-gracket) -(try-reader) +;(try-basic) +;(try-mzc) +;(try-extension) +;(try-gracket) +;(try-reader) (try-planet) ;; ---------------------------------------- From b6a4c4ed65ee74a013ba57f14eb392f84bcfbaee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Jul 2010 06:35:58 -0600 Subject: [PATCH 146/466] extend decompiler to handle #%variable-reference original commit: 5cc0baa01e353d5c523ab54d3729da6aef410c14 --- collects/compiler/decompile.rkt | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index b011c988ab..6c8c75d4a4 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -176,14 +176,21 @@ [(struct boxenv (pos body)) (extract-ids! body ids)] [else #f])) + +(define (decompile-tl expr globs stack closed no-check?) + (match expr + [(struct toplevel (depth pos const? ready?)) + (let ([id (list-ref/protect globs pos 'toplevel)]) + (if (or no-check? const? ready?) + id + `(#%checked ,id)))])) (define (decompile-expr expr globs stack closed) (match expr [(struct toplevel (depth pos const? ready?)) - (let ([id (list-ref/protect globs pos 'toplevel)]) - (if (or const? ready?) - id - `(#%checked ,id)))] + (decompile-tl expr globs stack closed #f)] + [(struct varref (tl)) + `(#%variable-reference ,(decompile-tl tl globs stack closed #t))] [(struct topsyntax (depth pos midpt)) (list-ref/protect globs (+ midpt pos) 'topsyntax)] [(struct primval (id)) From c1d54547d8faca03d893cd18a05ec5957221dbf4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Jul 2010 06:36:24 -0600 Subject: [PATCH 147/466] another ss->rkt repair to exe creator Merge to 5.0.1 original commit: ce03a3431829ac54a1cccfc392881eca1b766dcd --- collects/tests/racket/embed.rktl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 16a4e71a87..457f2ea6b4 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -461,6 +461,7 @@ (go '(planet racket-tester/p1/other) "two\nother\n") (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") (void)) @@ -469,11 +470,11 @@ ;; ---------------------------------------- -;(try-basic) -;(try-mzc) -;(try-extension) -;(try-gracket) -;(try-reader) +(try-basic) +(try-mzc) +(try-extension) +(try-gracket) +(try-reader) (try-planet) ;; ---------------------------------------- From 8e53d9458b2c81025ec4e3b1b9e963057d7bf604 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 19 Jul 2010 13:55:23 -0600 Subject: [PATCH 148/466] raco exe: fix missing ss->rkt conversion and remove debugging printf Merge to 5.0.1 (cherry picked from commit f602d11a7f77fb8cd14d11698150a8240a7d4b3f) original commit: 77a0796a6ca17b061cfb9531189276012ca66ff2 --- collects/tests/racket/embed.rktl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 25036d3566..16a4e71a87 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -460,6 +460,7 @@ (go '(planet racket-tester/p1/alt) "one\nalt\n") (go '(planet racket-tester/p1/other) "two\nother\n") (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (void)) @@ -468,11 +469,11 @@ ;; ---------------------------------------- -(try-basic) -(try-mzc) -(try-extension) -(try-gracket) -(try-reader) +;(try-basic) +;(try-mzc) +;(try-extension) +;(try-gracket) +;(try-reader) (try-planet) ;; ---------------------------------------- From b4ec84d1a9c3ce673ae2690547d3d400e7d69b95 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Jul 2010 06:36:24 -0600 Subject: [PATCH 149/466] another ss->rkt repair to exe creator Merge to 5.0.1 (cherry picked from commit ce03a3431829ac54a1cccfc392881eca1b766dcd) original commit: 6c79f0d39975a24038ea67269e6e92ae244b389c --- collects/tests/racket/embed.rktl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 16a4e71a87..457f2ea6b4 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -461,6 +461,7 @@ (go '(planet racket-tester/p1/other) "two\nother\n") (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") (void)) @@ -469,11 +470,11 @@ ;; ---------------------------------------- -;(try-basic) -;(try-mzc) -;(try-extension) -;(try-gracket) -;(try-reader) +(try-basic) +(try-mzc) +(try-extension) +(try-gracket) +(try-reader) (try-planet) ;; ---------------------------------------- From 78faf5e6d696686f75f57517b9fdab796fb5049c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 26 Jul 2010 11:45:01 -0600 Subject: [PATCH 150/466] zo-marshal wrap fixes, optional port for zo-parse original commit: 8eeed899824236c3c4a31954917c82d8f34d3948 --- collects/compiler/zo-marshal.rkt | 41 +++++++++++++++++++++++++---- collects/compiler/zo-parse.rkt | 3 ++- collects/tests/compiler/zo-test.rkt | 2 +- 3 files changed, 39 insertions(+), 7 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 8333ef8c23..f3b11324db 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -621,11 +621,42 @@ (define (encode-wrapped w) (match w [(struct wrapped (datum wraps certs)) - (vector - (cons - datum - (encode-wraps wraps)) - certs)])) + (let* ([enc-datum + (match datum + [(cons a b) + (let ([p (cons (encode-wrapped a) + (let bloop ([b b]) + (match b + ['() null] + [(cons b1 b2) + (cons (encode-wrapped b1) + (bloop b2))] + [else + (encode-wrapped b)])))] + [len (let loop ([datum datum][len 0]) + (cond + [(null? datum) #f] + [(pair? datum) (loop (cdr datum) (add1 len))] + [else len]))]) + ;; for improper lists, we need to include the length so the + ;; parser knows where the end of the improper list is + (if len + (cons len p) + p))] + [(box x) (box (encode-wrapped x))] + [(vector a ...) (list->vector + (map encode-wrapped a))] + [(? prefab-struct-key) + (let ([l (vector->list (struct->vector datum))]) + (make-prefab-struct + (car l) + (map encode-wrapped (cdr l))))] + [_ datum])] + [p (cons enc-datum + (encode-wraps wraps))]) + (if certs + (vector p certs) + p))])) (define (lookup-encoded-wrapped w out) (hash-ref (out-encoded-wraps out) w)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 7c1186ed64..8cca2af017 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -502,6 +502,7 @@ (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) + ;(printf "~s~n" v) (let-values ([(cert-marks v encoded-wraps) (match v [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] @@ -933,7 +934,7 @@ ;; path -> bytes ;; implementes read.c:read_compiled -(define (zo-parse port) +(define (zo-parse [port (current-input-port)]) (begin-with-definitions ;; skip the "#~" (unless (equal? #"#~" (read-bytes 2 port)) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index d280efac02..56cd89db6e 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -326,7 +326,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* #f (print-bytes read-orig marshal-parsed)] [c-parse-marshalled - #f + #t (read-compiled-bytes marshal-parsed)] [compare-orig-to-marshalled #f From 99c7fa04e209adf9da7e3921993db5e873d36308 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 26 Jul 2010 12:18:01 -0600 Subject: [PATCH 151/466] Fixing up a few things in zo-parse/etc original commit: 28432037af571e844cdcab35875e090d3800fc96 --- collects/compiler/zo-marshal.rkt | 17 ++++++++++------- collects/compiler/zo-parse.rkt | 1 - collects/tests/compiler/zo-test.rkt | 8 +++++--- 3 files changed, 15 insertions(+), 11 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index f3b11324db..ff27685f18 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require compiler/zo-structs scheme/port + racket/vector scheme/match scheme/contract scheme/local @@ -633,6 +634,7 @@ (bloop b2))] [else (encode-wrapped b)])))] + ; XXX Cylic list error possible [len (let loop ([datum datum][len 0]) (cond [(null? datum) #f] @@ -643,14 +645,15 @@ (if len (cons len p) p))] - [(box x) (box (encode-wrapped x))] - [(vector a ...) (list->vector - (map encode-wrapped a))] + [(box x) + (box (encode-wrapped x))] + [(? vector? v) + (vector-map encode-wrapped v)] [(? prefab-struct-key) - (let ([l (vector->list (struct->vector datum))]) - (make-prefab-struct - (car l) - (map encode-wrapped (cdr l))))] + (define l (vector->list (struct->vector datum))) + (make-prefab-struct + (car l) + (map encode-wrapped (cdr l)))] [_ datum])] [p (cons enc-datum (encode-wraps wraps))]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 8cca2af017..625de6963d 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -502,7 +502,6 @@ (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) - ;(printf "~s~n" v) (let-values ([(cert-marks v encoded-wraps) (match v [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index 56cd89db6e..81e86bd365 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -316,15 +316,15 @@ exec racket -t "$0" -- -s -t 60 -v -R $* [compare-marshalled-to-marshalled-marshalled #f (bytes-not-equal?-error marshal-parsed marshal-marshalled)] + #;[show-orig-and-marshal-parsed + #f + (print-bytes read-orig marshal-parsed)] #;[replace-with-marshalled #t (replace-file file marshal-marshalled)] [decompile-parsed #t (decompile parse-orig)] - [show-orig-and-marshal-parsed - #f - (print-bytes read-orig marshal-parsed)] [c-parse-marshalled #t (read-compiled-bytes marshal-parsed)] @@ -333,6 +333,8 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (bytes-not-equal?-error read-orig marshal-parsed)]) (define (run-test file) + (when (debugging?) + (printf "~a\n" file)) (run-with-limit file (* 1024 1024 128) From 9b95b870491055fe2326c24206b6c39ad1699843 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 27 Jul 2010 11:10:34 -0600 Subject: [PATCH 152/466] Fixing parts of zo-marshal re protect-quote; parallelizing zo-test; there is no the path error again in zo-marshal though original commit: 8d36dfad81c859968bff787b49de06b6889c736c --- collects/compiler/zo-marshal.rkt | 16 +- collects/tests/compiler/zo-exs.rkt | 15 +- collects/tests/compiler/zo-test-util.rkt | 12 + collects/tests/compiler/zo-test-worker.rkt | 270 +++++++++++ collects/tests/compiler/zo-test.rkt | 538 +++++++-------------- 5 files changed, 472 insertions(+), 379 deletions(-) create mode 100644 collects/tests/compiler/zo-test-util.rkt create mode 100644 collects/tests/compiler/zo-test-worker.rkt diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index ff27685f18..e8206838de 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -16,7 +16,6 @@ Less sharing occurs than in the C implementation, creating much larger files - protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off |# (define current-wrapped-ht (make-parameter #f)) @@ -681,11 +680,11 @@ (out-module form out)] [(struct def-values (ids rhs)) (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons rhs ids)) + (list->vector (cons (protect-quote rhs) ids)) out)] [(struct def-syntaxes (ids rhs prefix max-let-depth)) (out-syntax DEFINE_SYNTAX_EXPD - (list->vector (list* rhs + (list->vector (list* (protect-quote rhs) prefix max-let-depth *dummy* @@ -693,7 +692,7 @@ out)] [(struct def-for-syntax (ids rhs prefix max-let-depth)) (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* rhs + (list->vector (list* (protect-quote rhs) prefix max-let-depth *dummy* @@ -1091,11 +1090,12 @@ (define-struct quoted (v) #:prefab) +; protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off (define (protect-quote v) - v - #;(if (or (list? v) (vector? v) (box? v) (hash? v)) - (make-quoted v) - v)) + #;v + (if (or (list? v) (vector? v) (box? v) (hash? v)) + (make-quoted v) + v)) (define-struct svector (vec)) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index b8ab07e067..75aea4d252 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -19,4 +19,17 @@ (make-reader-graph ht)))))] (hash-test make-hash-placeholder) (hash-test make-hasheq-placeholder) - (hash-test make-hasheqv-placeholder))) + (hash-test make-hasheqv-placeholder)) + + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (current-directory))) + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list (current-directory))))) + + diff --git a/collects/tests/compiler/zo-test-util.rkt b/collects/tests/compiler/zo-test-util.rkt new file mode 100644 index 0000000000..cf5c40bd34 --- /dev/null +++ b/collects/tests/compiler/zo-test-util.rkt @@ -0,0 +1,12 @@ +#lang racket + +(struct result (phase) #:prefab) +(struct failure result (serious? msg) #:prefab) +(struct success result () #:prefab) + +(provide/contract + [struct result ([phase symbol?])] + [struct failure ([phase symbol?] + [serious? boolean?] + [msg string?])] + [struct success ([phase symbol?])]) \ No newline at end of file diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt new file mode 100644 index 0000000000..0a698fe246 --- /dev/null +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -0,0 +1,270 @@ +#lang racket/base +(require racket/cmdline + compiler/zo-parse + compiler/zo-marshal + compiler/decompile + racket/port + racket/bool + racket/list + racket/match + "zo-test-util.rkt") + +(define (bytes-gulp f) + (with-input-from-file f + (λ () (port->bytes (current-input-port))))) + +(define (read-compiled-bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (parameterize ([read-accept-compiled #t]) + (read ib))) + (lambda () + (close-input-port ib)))) + +(define (zo-parse/bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (zo-parse ib)) + (lambda () + (close-input-port ib)))) + +(define (bytes-not-equal?-error b1 b2) + (unless (bytes=? b1 b2) + (error 'bytes-not-equal?-error "Not equal"))) + +(define (replace-file file bytes) + (with-output-to-file file + (λ () (write-bytes bytes)) + #:exists 'truncate)) + +(define (equal?/why-not v1 v2) + (define v1->v2 (make-hasheq)) + (define (interned-symbol=? s1 s2) + (symbol=? (hash-ref! v1->v2 s1 s2) s2)) + (define (yield p m v1 v2) + (error 'equal?/why-not "~a in ~a: ~S ~S" + m (reverse p) v1 v2)) + (define (inner p v1 v2) + (unless (eq? v1 v2) + (match v1 + [(cons car1 cdr1) + (match v2 + [(cons car2 cdr2) + (inner (list* 'car p) car1 car2) + (inner (list* 'cdr p) cdr1 cdr2)] + [_ + (yield p "Not a cons on right" v1 v2)])] + [(? vector?) + (match v2 + [(? vector?) + (define v1l (vector-length v1)) + (define v2l (vector-length v2)) + (if (= v1l v2l) + (for ([i (in-range v1l)]) + (inner (list* `(vector-ref ,i) p) + (vector-ref v1 i) + (vector-ref v2 i))) + (yield p "Vector lengths not equal" v1 v2))] + [_ + (yield p "Not a vector on right" v1 v2)])] + [(? struct?) + (match v2 + [(? struct?) + (define vv1 (struct->vector v1)) + (define vv2 (struct->vector v2)) + (inner (list* `(struct->vector ,(vector-ref vv1 0)) p) + vv1 vv2)] + [_ + (yield p "Not a struct on right" v1 v2)])] + [(? hash?) + (match v2 + [(? hash?) + (let ([p (list* 'in-hash p)]) + (for ([(k1 hv1) (in-hash v1)]) + (define hv2 + (hash-ref v2 k1 + (lambda () + (yield p (format "~S not in hash on right" k1) v1 v2)))) + (inner (list* `(hash-ref ,k1) p) + hv1 hv2)))] + [_ + (yield p "Not a hash on right" v1 v2)])] + [(? module-path-index?) + (match v2 + [(? module-path-index?) + (define-values (mp1 bmpi1) (module-path-index-split v1)) + (define-values (mp2 bmpi2) (module-path-index-split v2)) + (inner (list* 'module-path-index-split_0 p) mp1 mp2) + (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)] + [_ + (yield p "Not a module path index on right" v1 v2)])] + [(? string?) + (match v2 + [(? string?) + (unless (string=? v1 v2) + (yield p "Unequal strings" v1 v2))] + [_ + (yield p "Not a string on right" v1 v2)])] + [(? bytes?) + (match v2 + [(? bytes?) + (unless (bytes=? v1 v2) + (yield p "Unequal bytes" v1 v2))] + [_ + (yield p "Not a bytes on right" v1 v2)])] + [(? path?) + (match v2 + [(? path?) + (unless (equal? v1 v2) + (yield p "Unequal paths" v1 v2))] + [_ + (yield p "Not a path on right" v1 v2)])] + [(? number?) + (match v2 + [(? number?) + (unless (equal? v1 v2) + (yield p "Unequal numbers" v1 v2))] + [_ + (yield p "Not a number on right" v1 v2)])] + [(? regexp?) + (match v2 + [(? regexp?) + (unless (string=? (object-name v1) (object-name v2)) + (yield p "Unequal regexp" v1 v2))] + [_ + (yield p "Not a regexp on right" v1 v2)])] + [(? byte-regexp?) + (match v2 + [(? byte-regexp?) + (unless (bytes=? (object-name v1) (object-name v2)) + (yield p "Unequal byte-regexp" v1 v2))] + [_ + (yield p "Not a byte-regexp on right" v1 v2)])] + [(? box?) + (match v2 + [(? box?) + (inner (list* 'unbox) (unbox v1) (unbox v2))] + [_ + (yield p "Not a box on right" v1 v2)])] + [(? symbol?) + (match v2 + [(? symbol?) + (unless (symbol=? v1 v2) + (cond + [(and (symbol-interned? v1) (not (symbol-interned? v1))) + (yield p "Not interned symbol on right" v1 v2)] + [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1))) + (yield p "Not unreadable symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1))) + (yield p "Not uninterned symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (symbol-uninterned? v2)) + (unless (interned-symbol=? v1 v2) + (yield p "Uninterned symbols don't align" v1 v2))] + [else + (yield p "Other symbol-related problem" v1 v2)]))] + [_ + (yield p "Not a symbol on right" v1 v2)])] + [(? empty?) + (yield p "Not empty on right" v1 v2)] + [_ + (yield p "Cannot inspect values deeper" v1 v2)]))) + (inner empty v1 v2)) + +(define (symbol-uninterned? s) + (not (or (symbol-interned? s) (symbol-unreadable? s)))) + +(define (run-with-limit file k thnk) + (define file-custodian (make-custodian)) + (define ch (make-channel)) + (custodian-limit-memory file-custodian k) + (define worker-thread + (parameterize ([current-custodian file-custodian]) + (thread + (lambda () + (define r (thnk)) + (channel-put ch r) + (channel-get ch))))) + (begin0 + (sync + (handle-evt ch + (lambda (v) + (when (exn? v) (raise v)) + v)) + (handle-evt worker-thread + (lambda _ + (record! (failure 'memory #f "Over memory limit"))))) + (custodian-shutdown-all file-custodian))) + +(define-syntax run/stages* + (syntax-rules () + [(_ file) + (record! (success 'everything))] + [(_ file [step1 serious? e] . rst) + (let/ec esc + (let ([step1 (with-handlers ([exn:fail? + (lambda (x) + (record! (failure 'step1 serious? + (exn-message x))) + (if serious? + (esc #f) + #f))]) + e)]) + (record! (success 'step1)) + (run/stages* file . rst)))])) + +(define-syntax-rule (define-stages (run! file) + [stage serious? e] ...) + (define (run! file) + (run/stages* file [stage serious? e] ...))) + +(define-stages (run! file) + [read-orig + #t + (bytes-gulp file)] + [parse-orig + #t + (zo-parse/bytes read-orig)] + [marshal-parsed + #t + (zo-marshal parse-orig)] + [parse-marshalled + #t + (zo-parse/bytes marshal-parsed)] + [compare-parsed-to-parsed-marshalled + #f + (equal?/why-not parse-orig parse-marshalled)] + [marshal-marshalled + #t + (zo-marshal parse-marshalled)] + [compare-marshalled-to-marshalled-marshalled + #f + (bytes-not-equal?-error marshal-parsed marshal-marshalled)] + #;[replace-with-marshalled + #t + (replace-file file marshal-marshalled)] + [decompile-parsed + #t + (decompile parse-orig)] + [c-parse-marshalled + #t + (read-compiled-bytes marshal-parsed)] + [compare-orig-to-marshalled + #f + (bytes-not-equal?-error read-orig marshal-parsed)]) + +(define RESULTS empty) +(define (record! v) + (set! RESULTS (list* v RESULTS))) +(define (run-test file) + (run-with-limit + file + (* 1024 1024 128) + (lambda () + (run! file))) + (write (reverse RESULTS))) + +(command-line #:program "zo-test-worker" + #:args (file) + (run-test file)) \ No newline at end of file diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index 81e86bd365..31ee8825d8 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -3,204 +3,15 @@ exec racket -t "$0" -- -s -t 60 -v -R $* |# -#lang scheme -(require compiler/zo-parse - compiler/zo-marshal - compiler/decompile - setup/dirs) - -;; Helpers -(define (bytes->hex-string bs) - (apply string-append - (for/list ([b bs]) - (format "~a~x" - (if (b . <= . 15) "0" "") - b)))) - -(define (show-bytes-side-by-side orig new) - (define max-length - (max (bytes-length orig) (bytes-length new))) - (define BYTES-PER-LINE 38) - (define lines - (ceiling (/ max-length BYTES-PER-LINE))) - (define (subbytes* b s e) - (subbytes b (min s (bytes-length b)) (min e (bytes-length b)))) - (for ([line (in-range lines)]) - (define start (* line BYTES-PER-LINE)) - (define end (* (add1 line) BYTES-PER-LINE)) - (printf "+ ~a\n" (bytes->hex-string (subbytes* orig start end))) - (printf "- ~a\n" (bytes->hex-string (subbytes* new start end))))) - -(define (bytes-gulp f) - (with-input-from-file f - (λ () (port->bytes (current-input-port))))) - -(define (read-compiled-bytes bs) - (define ib (open-input-bytes bs)) - (dynamic-wind void - (lambda () - (parameterize ([read-accept-compiled #t]) - (read ib))) - (lambda () - (close-input-port ib)))) - -(define (zo-parse/bytes bs) - (define ib (open-input-bytes bs)) - (dynamic-wind void - (lambda () - (zo-parse ib)) - (lambda () - (close-input-port ib)))) - -(define (bytes-not-equal?-error b1 b2) - (unless (bytes=? b1 b2) - (error 'bytes-not-equal?-error "Not equal"))) - -(define (replace-file file bytes) - (with-output-to-file file - (λ () (write-bytes bytes)) - #:exists 'truncate)) +#lang racket +(require setup/dirs + racket/runtime-path + racket/future + "zo-test-util.rkt") (define ((make-recorder! ht) file phase) (hash-update! ht phase (curry list* file) empty)) -(define (equal?/why-not v1 v2) - (define v1->v2 (make-hasheq)) - (define (interned-symbol=? s1 s2) - (symbol=? (hash-ref! v1->v2 s1 s2) s2)) - (define (yield p m v1 v2) - (error 'equal?/why-not "~a in ~a: ~S ~S" - m (reverse p) v1 v2)) - (define (inner p v1 v2) - (unless (eq? v1 v2) - (match v1 - [(cons car1 cdr1) - (match v2 - [(cons car2 cdr2) - (inner (list* 'car p) car1 car2) - (inner (list* 'cdr p) cdr1 cdr2)] - [_ - (yield p "Not a cons on right" v1 v2)])] - [(? vector?) - (match v2 - [(? vector?) - (define v1l (vector-length v1)) - (define v2l (vector-length v2)) - (if (= v1l v2l) - (for ([i (in-range v1l)]) - (inner (list* `(vector-ref ,i) p) - (vector-ref v1 i) - (vector-ref v2 i))) - (yield p "Vector lengths not equal" v1 v2))] - [_ - (yield p "Not a vector on right" v1 v2)])] - [(? struct?) - (match v2 - [(? struct?) - (define vv1 (struct->vector v1)) - (define vv2 (struct->vector v2)) - (inner (list* `(struct->vector ,(vector-ref vv1 0)) p) - vv1 vv2)] - [_ - (yield p "Not a struct on right" v1 v2)])] - [(? hash?) - (match v2 - [(? hash?) - (let ([p (list* 'in-hash p)]) - (for ([(k1 hv1) (in-hash v1)]) - (define hv2 - (hash-ref v2 k1 - (lambda () - (yield p (format "~S not in hash on right" k1) v1 v2)))) - (inner (list* `(hash-ref ,k1) p) - hv1 hv2)))] - [_ - (yield p "Not a hash on right" v1 v2)])] - [(? module-path-index?) - (match v2 - [(? module-path-index?) - (define-values (mp1 bmpi1) (module-path-index-split v1)) - (define-values (mp2 bmpi2) (module-path-index-split v2)) - (inner (list* 'module-path-index-split_0 p) mp1 mp2) - (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)] - [_ - (yield p "Not a module path index on right" v1 v2)])] - [(? string?) - (match v2 - [(? string?) - (unless (string=? v1 v2) - (yield p "Unequal strings" v1 v2))] - [_ - (yield p "Not a string on right" v1 v2)])] - [(? bytes?) - (match v2 - [(? bytes?) - (unless (bytes=? v1 v2) - (yield p "Unequal bytes" v1 v2))] - [_ - (yield p "Not a bytes on right" v1 v2)])] - [(? path?) - (match v2 - [(? path?) - (unless (equal? v1 v2) - (yield p "Unequal paths" v1 v2))] - [_ - (yield p "Not a path on right" v1 v2)])] - [(? number?) - (match v2 - [(? number?) - (unless (equal? v1 v2) - (yield p "Unequal numbers" v1 v2))] - [_ - (yield p "Not a number on right" v1 v2)])] - [(? regexp?) - (match v2 - [(? regexp?) - (unless (string=? (object-name v1) (object-name v2)) - (yield p "Unequal regexp" v1 v2))] - [_ - (yield p "Not a regexp on right" v1 v2)])] - [(? byte-regexp?) - (match v2 - [(? byte-regexp?) - (unless (bytes=? (object-name v1) (object-name v2)) - (yield p "Unequal byte-regexp" v1 v2))] - [_ - (yield p "Not a byte-regexp on right" v1 v2)])] - [(? box?) - (match v2 - [(? box?) - (inner (list* 'unbox) (unbox v1) (unbox v2))] - [_ - (yield p "Not a box on right" v1 v2)])] - [(? symbol?) - (match v2 - [(? symbol?) - (unless (symbol=? v1 v2) - (cond - [(and (symbol-interned? v1) (not (symbol-interned? v1))) - (yield p "Not interned symbol on right" v1 v2)] - [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1))) - (yield p "Not unreadable symbol on right" v1 v2)] - [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1))) - (yield p "Not uninterned symbol on right" v1 v2)] - [(and (symbol-uninterned? v1) (symbol-uninterned? v2)) - (unless (interned-symbol=? v1 v2) - (yield p "Uninterned symbols don't align" v1 v2))] - [else - (yield p "Other symbol-related problem" v1 v2)]))] - [_ - (yield p "Not a symbol on right" v1 v2)])] - [(? empty?) - (yield p "Not empty on right" v1 v2)] - [_ - (yield p "Cannot inspect values deeper" v1 v2)]))) - (inner empty v1 v2)) - -(define (symbol-uninterned? s) - (not (or (symbol-interned? s) (symbol-unreadable? s)))) - -;; Parameters (define stop-on-first-error (make-parameter #f)) (define verbose-mode (make-parameter #f)) (define care-about-nonserious? (make-parameter #t)) @@ -208,139 +19,23 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (define time-limit (make-parameter +inf.0)) (define randomize (make-parameter #f)) -;; Work (define errors (make-hash)) +(define (record-common-error! exn-msg) + (hash-update! errors (common-message exn-msg) add1 0)) -(define (common-message exn) - (define given-messages (regexp-match #rx".*given" (exn-message exn))) +(define (common-message exn-msg) + (define given-messages (regexp-match #rx".*given" exn-msg)) (if (and given-messages (not (empty? given-messages))) (first given-messages) - (exn-message exn))) - -(define (exn-printer file phase serious? exn) - (hash-update! errors (common-message exn) add1 0) - (unless (and (not (care-about-nonserious?)) (not serious?)) - (when (or (verbose-mode) (stop-on-first-error)) - (fprintf (current-error-port) "~a -- ~a: ~a~n" file phase (exn-message exn))) - (when (stop-on-first-error) - exn))) - -(define (run-with-time-limit t thnk) - (define th (thread thnk)) - (sync th - (handle-evt (alarm-evt (+ (current-inexact-milliseconds) - (* 1000 t))) - (lambda _ - (kill-thread th))))) - -(define (run-with-limit file k thnk) - (define file-custodian (make-custodian)) - (define ch (make-channel)) - (custodian-limit-memory file-custodian k) - (local [(define worker-thread - (parameterize ([current-custodian file-custodian]) - (thread - (lambda () - (define r (thnk)) - (channel-put ch r) - (channel-get ch)))))] - (begin0 - (sync - (handle-evt ch - (lambda (v) - (when (exn? v) (raise v)) - v)) - (handle-evt worker-thread - (lambda _ - (failure! file 'memory)))) - (custodian-shutdown-all file-custodian)))) + exn-msg)) (define success-ht (make-hasheq)) (define success! (make-recorder! success-ht)) (define failure-ht (make-hasheq)) (define failure! (make-recorder! failure-ht)) -(define-syntax run/stages* - (syntax-rules () - [(_ file) (success! file 'everything)] - [(_ file [step1 serious? e] . rst) - (let/ec esc - (let ([step1 (with-handlers ([exn:fail? - (lambda (x) - (failure! file 'step1) - (esc (exn-printer file 'step1 serious? x)))]) - e)]) - (success! file 'step1) - (run/stages* file . rst)))])) - -(define-syntax-rule (define-stages (stages run!) - file - [stage serious? e] ...) - (define-values (stages run!) - (values '(stage ...) - (lambda (file) - (run/stages* file [stage serious? e] ...))))) - (define debugging? (make-parameter #f)) -(define (print-bytes orig new) - (when (debugging?) - (show-bytes-side-by-side orig new)) - #t) - -(define-stages (stages run!) - file - [read-orig - #t - (bytes-gulp file)] - [parse-orig - #t - (zo-parse/bytes read-orig)] - [marshal-parsed - #t - (zo-marshal parse-orig)] - #;[ignored - #f - (printf "orig: ~a, marshalled: ~a~n" - (bytes-length read-orig) - (bytes-length marshal-parsed))] - [parse-marshalled - #t - (zo-parse/bytes marshal-parsed)] - [compare-parsed-to-parsed-marshalled - #f - (equal?/why-not parse-orig parse-marshalled)] - [marshal-marshalled - #t - (zo-marshal parse-marshalled)] - [compare-marshalled-to-marshalled-marshalled - #f - (bytes-not-equal?-error marshal-parsed marshal-marshalled)] - #;[show-orig-and-marshal-parsed - #f - (print-bytes read-orig marshal-parsed)] - #;[replace-with-marshalled - #t - (replace-file file marshal-marshalled)] - [decompile-parsed - #t - (decompile parse-orig)] - [c-parse-marshalled - #t - (read-compiled-bytes marshal-parsed)] - [compare-orig-to-marshalled - #f - (bytes-not-equal?-error read-orig marshal-parsed)]) - -(define (run-test file) - (when (debugging?) - (printf "~a\n" file)) - (run-with-limit - file - (* 1024 1024 128) - (lambda () - (run! file)))) - (define (randomize-list l) (define ll (length l)) (define seen? (make-hasheq)) @@ -366,59 +61,162 @@ exec racket -t "$0" -- -s -t 60 -v -R $* [(regexp-match #rx"\\.zo$" p-str) (! p-str)])) -(define (zo-test paths) - (run-with-time-limit - (time-limit) - (lambda () - (for-each (curry for-zos run-test) paths))) - - (unless (invariant-output) - (for ([kind-name (list* 'memory stages)]) - (define fails (length (hash-ref failure-ht kind-name empty))) - (define succs (length (hash-ref success-ht kind-name empty))) - (define all (+ fails succs)) - (unless (zero? all) - (printf "~S~n" - `(,kind-name - (#f ,fails) - (#t ,succs) - ,all)))) - (printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty))) - - (printf "Common Errors:~n") - - (for ([p (in-list (sort (filter (λ (p) ((car p) . > . 10)) - (hash-map errors (λ (k v) (cons v k)))) - > #:key car))]) - (printf "~a:~n~a~n~n" (car p) (cdr p))))) +(define-runtime-path zo-test-worker-path "zo-test-worker.rkt") +(define racket-path (path->string (find-executable-path "racket"))) -; Run -#;(current-command-line-arguments #("-s" "/home/bjohn3x/development/plt/collects/browser/compiled/browser_scrbl.zo")) -(command-line #:program "zo-test" - #:once-each - [("-D") - "Enable debugging output" - (debugging? #t)] - [("-s" "--stop-on-first-error") - "Stop testing when first error is encountered" - (stop-on-first-error #t)] - [("-S") - "Don't take some errors seriously" - (care-about-nonserious? #f)] - [("-v" "--verbose") - "Display verbose error messages" - (verbose-mode #t)] - [("-I") - "Invariant output" - (invariant-output #t)] - [("-R") - "Randomize" - (randomize #t)] - [("-t") - number - "Limit the run to a given amount of time" - (time-limit (string->number number))] - #:args p - (zo-test (if (empty? p) - (list (find-collects-dir)) - p))) \ No newline at end of file +(define p + (command-line #:program "zo-test" + #:once-each + [("-D") + "Enable debugging output" + (debugging? #t)] + [("-s" "--stop-on-first-error") + "Stop testing when first error is encountered" + (stop-on-first-error #t)] + [("-S") + "Don't take some errors seriously" + (care-about-nonserious? #f)] + [("-v" "--verbose") + "Display verbose error messages" + (verbose-mode #t)] + [("-I") + "Invariant output" + (invariant-output #t)] + [("-R") + "Randomize" + (randomize #t)] + [("-t") + number + "Limit the run to a given amount of time" + (time-limit (string->number number))] + #:args p + (if (empty? p) + (list (find-collects-dir)) + p))) + +(define to-worker-ch (make-channel)) +(define stop-ch (make-channel)) +(define from-worker-ch (make-channel)) + +(define worker-threads + (for/list ([i (in-range (processor-count))]) + (thread + (λ () + (let loop () + (sync + (handle-evt to-worker-ch + (λ (p) + (when (debugging?) + (printf "~a\n" p)) + (define-values + (sp stdout stdin _stderr) + (subprocess #f #f #f racket-path (path->string zo-test-worker-path) p)) + (define r + (dynamic-wind + void + (λ () + (read stdout)) + (λ () + (close-input-port stdout) + (close-output-port stdin) + (subprocess-kill sp #t)))) + (channel-put from-worker-ch (cons p r)) + (loop))) + (handle-evt stop-ch + (λ (die) + (void))))))))) + +(define (process-result p r) + (match r + [(success phase) + (success! p phase)] + [(failure phase serious? exn-msg) + (record-common-error! exn-msg) + (failure! p phase) + + (unless (and (not (care-about-nonserious?)) (not serious?)) + (when (or (verbose-mode) (stop-on-first-error)) + (fprintf (current-error-port) "~a -- ~a: ~a\n" p phase exn-msg)) + (when (stop-on-first-error) + (stop!)))])) + +(define timing-thread + (thread + (λ () + (sync + (alarm-evt (+ (current-inexact-milliseconds) + (* 1000 (time-limit))))) + (stop!)))) + +(define server-thread + (thread + (λ () + (let loop ([ts worker-threads]) + (if (empty? ts) + (stop!) + (apply + sync + (handle-evt from-worker-ch + (match-lambda + [(cons p rs) + (for-each (curry process-result p) rs) + (loop ts)])) + (for/list ([t (in-list ts)]) + (handle-evt t (λ _ (loop (remq t ts))))))))))) + +(define (spawn-worker p) + (channel-put to-worker-ch p)) + +(define (zo-test paths) + (for-each (curry for-zos spawn-worker) paths) + + (for ([i (in-range (processor-count))]) + (channel-put stop-ch #t))) + +(define root-thread + (thread + (λ () + (zo-test p)))) + +(define final-sema (make-semaphore 0)) +(define (stop!) + (semaphore-post final-sema)) + +(define (hash-keys ht) + (hash-map ht (λ (k v) k))) + +(define final-thread + (thread + (λ () + (semaphore-wait final-sema) + (for-each kill-thread + (list* root-thread server-thread worker-threads)) + (unless (invariant-output) + (newline) + (for ([kind-name + (remove-duplicates + (append + (hash-keys failure-ht) + (hash-keys success-ht)))]) + (define fails (length (hash-ref failure-ht kind-name empty))) + (define succs (length (hash-ref success-ht kind-name empty))) + (define all (+ fails succs)) + (unless (zero? all) + (printf "~S~n" + `(,kind-name + (#f ,fails) + (#t ,succs) + ,all)))) + (newline) + (printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty))) + + (let ([common-errors + (sort (filter (λ (p) ((car p) . > . 10)) + (hash-map errors (λ (k v) (cons v k)))) + > #:key car)]) + (unless (empty? common-errors) + (printf "Common Errors:~n") + (for ([p (in-list common-errors)]) + (printf "~a:~n~a~n~n" (car p) (cdr p))))))))) + +(thread-wait final-thread) \ No newline at end of file From d8dae45321e14ec4d2df01808ed52aae8845fa28 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 27 Jul 2010 12:48:57 -0600 Subject: [PATCH 153/466] Do not use CPT_ESCAPE for every CPT_QUOTE, instead if it was a protect-quote, then just put the CPT_QUOTE in. original commit: 53fdc09e7a071b93b67e84e617487e46e95e7689 --- collects/compiler/zo-marshal.rkt | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e8206838de..27b7e7f7d8 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -778,9 +778,9 @@ out)] [(struct let-one (rhs body flonum? unused?)) (out-byte (cond - [flonum? CPT_LET_ONE_FLONUM] - [unused? CPT_LET_ONE_UNUSED] - [else CPT_LET_ONE]) + [flonum? CPT_LET_ONE_FLONUM] + [unused? CPT_LET_ONE_UNUSED] + [else CPT_LET_ONE]) out) (out-expr (protect-quote rhs) out) (out-expr (protect-quote body) out)] @@ -1078,14 +1078,14 @@ (out-wrapped expr out)] [else (out-byte CPT_QUOTE out) - (let ([s (open-output-bytes)]) - (write (if (quoted? expr) - (quoted-v expr) - expr) s) - (out-byte CPT_ESCAPE out) - (let ([bstr (get-output-bytes s)]) - (out-number (bytes-length bstr) out) - (out-bytes bstr out)))])) + (if (quoted? expr) + (out-data (quoted-v expr) out) + (let ([s (open-output-bytes)]) + (write expr s) + (out-byte CPT_ESCAPE out) + (let ([bstr (get-output-bytes s)]) + (out-number (bytes-length bstr) out) + (out-bytes bstr out))))])) (define-struct quoted (v) #:prefab) From b662bdef4c3561975d3ab3f015686d821615e857 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 27 Jul 2010 13:41:58 -0600 Subject: [PATCH 154/466] closing stderr in zo-test original commit: 8b195d1c3c54cdac25c28f1619a4babf72f0d311 --- collects/tests/compiler/zo-test.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index 31ee8825d8..dc4f49f939 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -109,7 +109,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (when (debugging?) (printf "~a\n" p)) (define-values - (sp stdout stdin _stderr) + (sp stdout stdin stderr) (subprocess #f #f #f racket-path (path->string zo-test-worker-path) p)) (define r (dynamic-wind @@ -118,6 +118,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (read stdout)) (λ () (close-input-port stdout) + (close-input-port stderr) (close-output-port stdin) (subprocess-kill sp #t)))) (channel-put from-worker-ch (cons p r)) From 8e7a64be3fafa2e7b5c98b7ad3dc0af88605c514 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 28 Jul 2010 14:39:01 -0600 Subject: [PATCH 155/466] added another case for all-from-module renames original commit: 2dfd34003179b950b552b5c0d5c247c062badc49 --- collects/compiler/zo-marshal.rkt | 14 ++++++----- collects/compiler/zo-parse.rkt | 41 +++++++++++++------------------- 2 files changed, 24 insertions(+), 31 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 27b7e7f7d8..5e47a7ea18 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -576,12 +576,14 @@ (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) encoded-bindings) -(define (encode-all-from-module all) - (match all - [(struct all-from-module (path phase src-phase exceptions prefix)) - (if (and (empty? exceptions) (not prefix)) - (list* path phase src-phase) - (list* path phase src-phase (append exceptions prefix)))])) +(define encode-all-from-module + (match-lambda + [(struct all-from-module (path phase src-phase (list) #f)) + (list* path phase src-phase)] + [(struct all-from-module (path phase src-phase exns #f)) + (list* path phase exns src-phase)] + [(struct all-from-module (path phase src-phase exns prefix)) + (list* path phase src-phase (append exns prefix))])) (define (encode-wraps wraps) (for/list ([wrap (in-list wraps)]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 625de6963d..051b578d40 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -594,31 +594,22 @@ (make-module-rename phase (if kind 'marked 'normal) set-id - (let ([results (map (lambda (u) - ; u = (list path phase . src-phase) - ; or u = (list path phase src-phase exn ... . prefix) - (let ([just-phase? (let ([v (cddr u)]) - (or (number? v) (not v)))]) - (let-values ([(exns prefix) - (if just-phase? - (values null #f) - (let loop ([u (if just-phase? null (cdddr u))] - [a null]) - (if (pair? u) - (loop (cdr u) (cons (car u) a)) - (values (reverse a) u))))]) - (make-all-from-module - (parse-module-path-index cp (car u)) - (cadr u) - (if just-phase? - (cddr u) - (caddr u)) - exns - prefix)))) - unmarshals)]) - #;(printf "~nunmarshals: ~S~n" unmarshals) - #;(printf "~nunmarshal results: ~S~n" results) - results) + (map (local [(define (phase? v) + (or (number? v) (not v)))] + (match-lambda + [(list* path (? phase? phase) (? phase? src-phase) exn ... prefix) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn prefix)] + [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn #f)] + [(list* path (? phase? phase) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase empty #f)])) + unmarshals) (decode-renames renames) mark-renames (and plus-kern? 'plus-kern)))] From bb6903c6bf2d2301886a695c733ceaca306dac2e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 30 Jul 2010 04:20:46 -0400 Subject: [PATCH 156/466] typo original commit: 14de7399bd592b76899acc00611b47952c9ce90d --- collects/compiler/commands/exe.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index 59a956f60f..117e44429b 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -23,7 +23,7 @@ #:once-each [("-o") file "Write executable as " (exe-output file)] - [("--gui") "Geneate GUI executable" + [("--gui") "Generate GUI executable" (gui #t)] [("--collects-path") path "Set as main collects for executable" (exe-embedded-collects-path path)] From ad67592f9815327c508640e72925087020ec8ae6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 30 Jul 2010 04:20:46 -0400 Subject: [PATCH 157/466] typo (cherry picked from commit 14de7399bd592b76899acc00611b47952c9ce90d) original commit: 700cb5ee8d2adff343ef79732c2010e7c55cae7d --- collects/compiler/commands/exe.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index 59a956f60f..117e44429b 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -23,7 +23,7 @@ #:once-each [("-o") file "Write executable as " (exe-output file)] - [("--gui") "Geneate GUI executable" + [("--gui") "Generate GUI executable" (gui #t)] [("--collects-path") path "Set as main collects for executable" (exe-embedded-collects-path path)] From 7c32e885f3ad769cb85f3848d2dd2f08c86c7906 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 30 Jul 2010 14:00:11 -0600 Subject: [PATCH 158/466] better certificate handling in zo-parse and zo-marshal original commit: 80c6ba482ded562f53b2625cfc32de9e795d4275 --- collects/compiler/zo-marshal.rkt | 26 ++++++++++++++++++++++++-- collects/compiler/zo-parse.rkt | 22 +++++++++++++++++++++- collects/compiler/zo-structs.rkt | 21 ++++++++++++++++++++- 3 files changed, 65 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 5e47a7ea18..c466244325 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -76,7 +76,8 @@ (write-bytes #"#~" outp) (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) - (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (define symtabsize (add1 (hash-count shared))) + (write-bytes (int->bytes symtabsize) outp) (write-bytes (bytes (if all-short? 1 0)) outp) (for ([o (in-list offsets)]) (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) @@ -233,6 +234,8 @@ (for ([(k v) (in-hash expr)]) (traverse-data k visit) (traverse-data v visit)))] + [(protected-symref? expr) + (visit (protected-symref-val expr))] [else (void)])) @@ -620,6 +623,21 @@ [(struct wrap-mark (val)) (list val)]))) +(define (encode-mark-map mm) + mm + #;(for/fold ([l empty]) + ([(k v) (in-hash ht)]) + (list* k v l))) + +(define-struct protected-symref (val)) + +(define encode-certs + (match-lambda + [(struct certificate:nest (m1 m2)) + (list* (encode-mark-map m1) (encode-mark-map m2))] + [(struct certificate:ref (val m)) + (list* #f (make-protected-symref val) (encode-mark-map m))])) + (define (encode-wrapped w) (match w [(struct wrapped (datum wraps certs)) @@ -659,7 +677,7 @@ [p (cons enc-datum (encode-wraps wraps))]) (if certs - (vector p certs) + (vector p (encode-certs certs)) p))])) (define (lookup-encoded-wrapped w out) @@ -932,6 +950,10 @@ (define (out-value expr out) (cond + [(protected-symref? expr) + (let* ([val (protected-symref-val expr)] + [val-ref ((out-shared-index out) val)]) + (out-value val-ref out))] [(and (symbol? expr) (not (symbol-interned? expr))) (out-as-bytes expr #:before-length (if (symbol-unreadable? expr) 0 1) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 051b578d40..4c29dab5ce 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -498,6 +498,25 @@ ;; ---------------------------------------- ;; Syntax unmarshaling +(define (decode-mark-map alist) + alist + #;(let loop ([alist alist] + [ht (make-immutable-hasheq empty)]) + (match alist + [(list) ht] + [(list* (? number? key) (? module-path-index? val) alist) + (loop alist (hash-set ht key val))]))) + +(define (decode-marks cp ms) + (match ms + [#f #f] + [(list* #f (? number? symref) alist) + (make-certificate:ref + (vector-ref (cport-symtab cp) symref) + (decode-mark-map alist))] + [(list* (? list? nested) alist) + (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))])) + (define (decode-stx cp v) (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) @@ -508,7 +527,8 @@ [`(,datum . ,wraps) (values #f datum wraps)] [else (error 'decode-wraps "bad datum+wrap: ~e" v)])]) (let* ([wraps (decode-wraps cp encoded-wraps)] - [add-wrap (lambda (v) (make-wrapped v wraps cert-marks))]) + [marks (decode-marks cp cert-marks)] + [add-wrap (lambda (v) (make-wrapped v wraps marks))]) (cond [(pair? v) (if (eq? #t (car v)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index daba19df57..e776109093 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -42,10 +42,29 @@ [phase (or/c 0 1)])) ; direct access to exported id ;; Syntax object +(define ((alist/c k? v?) l) + (let loop ([l l]) + (match l + [(list) #t] + [(list* (? k?) (? v?) l) + (loop l)] + [_ #f]))) + +(define mark-map? + (alist/c number? module-path-index?) + #;(hash/c number? module-path-index?)) +(define-form-struct certificate ()) +(define-form-struct (certificate:nest certificate) + ([nested mark-map?] + [map mark-map?])) +(define-form-struct (certificate:ref certificate) + ([val any/c] + [map mark-map?])) + (define-form-struct wrap ()) (define-form-struct wrapped ([datum any/c] [wraps (listof wrap?)] - [certs (or/c list? #f)])) + [certs (or/c certificate? #f)])) ;; In stxs of prefix: (define-form-struct stx ([encoded wrapped?])) From f7c42c1e6a588a128fbb56b167e0032a047819d3 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 30 Jul 2010 15:30:14 -0600 Subject: [PATCH 159/466] Added case in zo-marshal for prefab structs Made quoted not-prefab so it isn't captured by prefab case original commit: 63c6cc5d2c6ae3b467bcbe54931885964b720802 --- collects/compiler/zo-marshal.rkt | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index c466244325..2f809b47bb 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -234,6 +234,11 @@ (for ([(k v) (in-hash expr)]) (traverse-data k visit) (traverse-data v visit)))] + [(prefab-struct-key expr) + (when (visit expr) + (let ([v (struct->vector expr)]) + (for ([i (in-range 1 (vector-length v))]) + (traverse-data (vector-ref v i) visit))))] [(protected-symref? expr) (visit (protected-symref-val expr))] [else @@ -310,7 +315,7 @@ CPT_MODULE_VAR CPT_PATH CPT_CLOSURE - CPT_DELAY_REF + CPT_DELAY_REF ; XXX unused, but appears to be same as CPT_SYMREF CPT_PREFAB CPT_LET_ONE_UNUSED) @@ -681,7 +686,9 @@ p))])) (define (lookup-encoded-wrapped w out) - (hash-ref (out-encoded-wraps out) w)) + (hash-ref (out-encoded-wraps out) w + (lambda () + (error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w)))) (define (out-wrapped w out) (out-data (lookup-encoded-wrapped w out) out)) @@ -1053,6 +1060,7 @@ (print-contents-as-proper) (out-data null out))) (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) + ; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR (begin (out-byte (+ CPT_SMALL_LIST_START len) out) (print-contents-as-improper)) (begin (out-byte CPT_LIST out) @@ -1099,7 +1107,13 @@ [(stx? expr) (out-stx expr out)] [(wrapped? expr) - (out-wrapped expr out)] + (out-wrapped expr out)] + [(prefab-struct-key expr) + => (lambda (key) + (define pre-v (struct->vector expr)) + (vector-set! pre-v 0 key) + (out-byte CPT_PREFAB out) + (out-data pre-v out))] [else (out-byte CPT_QUOTE out) (if (quoted? expr) @@ -1112,12 +1126,12 @@ (out-bytes bstr out))))])) -(define-struct quoted (v) #:prefab) +(define-struct quoted (v)) ; protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off (define (protect-quote v) #;v - (if (or (list? v) (vector? v) (box? v) (hash? v)) + (if (or (pair? v) (vector? v) (prefab-struct-key v) (box? v) (hash? v) (svector? v)) (make-quoted v) v)) From 2efb39c39194f163f70f567eae5de0e5bf5f7cb0 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 29 Jul 2010 15:52:12 -0600 Subject: [PATCH 160/466] another all-from-module fix original commit: 7653ce037bdb099a859a2008001ae271eaa65ba3 --- collects/compiler/zo-marshal.rkt | 8 ++++---- collects/compiler/zo-parse.rkt | 11 +++++------ collects/compiler/zo-structs.rkt | 4 ++-- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 2f809b47bb..d3b0210063 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -586,12 +586,12 @@ (define encode-all-from-module (match-lambda - [(struct all-from-module (path phase src-phase (list) #f)) - (list* path phase src-phase)] + [(struct all-from-module (path phase src-phase #f #f)) + (list* path phase src-phase)] [(struct all-from-module (path phase src-phase exns #f)) (list* path phase exns src-phase)] - [(struct all-from-module (path phase src-phase exns prefix)) - (list* path phase src-phase (append exns prefix))])) + [(struct all-from-module (path phase src-phase exns (vector prefix))) + (list* path phase src-phase exns prefix)])) (define (encode-wraps wraps) (for/list ([wrap (in-list wraps)]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 4c29dab5ce..e7adc72a82 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -26,8 +26,6 @@ I think parse-module-path-index was only used for debugging, so it is short-circuited now - collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (# 0 (1363072) . #f) --- that doesn't seem to match the spec - |# ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -587,7 +585,7 @@ [(integer? a) (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] ; A mark (not actually a number as the C says, but a (list ) - [(and (pair? a) (null? (cdr a)) (number? (car a))) + [(and (pair? a) (number? (car a))) (make-wrap-mark (car a))] [(vector? a) @@ -617,10 +615,11 @@ (map (local [(define (phase? v) (or (number? v) (not v)))] (match-lambda - [(list* path (? phase? phase) (? phase? src-phase) exn ... prefix) + [(list* path (? phase? phase) (? phase? src-phase) + (list exn ...) prefix) (make-all-from-module (parse-module-path-index cp path) - phase src-phase exn prefix)] + phase src-phase exn (vector prefix))] [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) (make-all-from-module (parse-module-path-index cp path) @@ -628,7 +627,7 @@ [(list* path (? phase? phase) (? phase? src-phase)) (make-all-from-module (parse-module-path-index cp path) - phase src-phase empty #f)])) + phase src-phase #f #f)])) unmarshals) (decode-renames renames) mark-renames diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index e776109093..8cc5042729 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -179,8 +179,8 @@ (define-form-struct all-from-module ([path module-path-index?] [phase (or/c exact-integer? #f)] [src-phase any/c] ; should be (or/c exact-integer? #f) - [exceptions list?] ; should be (listof symbol?) - [prefix any/c])) ; should be (or/c symbol? #f) + [exceptions (or/c (listof symbol?) #f)] ; should be (listof symbol?) + [prefix (or/c (vector/c (or/c symbol? #f)) #f)])) ; should be (or/c symbol? #f) (define-form-struct nominal-path ()) (define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?])) From c998fe85e9d67502ee58fb9b8722feaaaa230702 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 2 Aug 2010 16:18:11 -0600 Subject: [PATCH 161/466] applying make-prefab-struct original commit: 551ef5ba30fbd274fc30f53cd06d9926873eff28 --- collects/compiler/zo-marshal.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index d3b0210063..6e0d8ae475 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -675,7 +675,8 @@ (vector-map encode-wrapped v)] [(? prefab-struct-key) (define l (vector->list (struct->vector datum))) - (make-prefab-struct + (apply + make-prefab-struct (car l) (map encode-wrapped (cdr l)))] [_ datum])] From aee68bb7884e5adf336e878cce4c72e91d445474 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 3 Aug 2010 15:19:30 -0600 Subject: [PATCH 162/466] cases for more complicated lexical renames original commit: b062c900a1b7e153aea8fd317f323d0c479bfc3c --- collects/compiler/zo-marshal.rkt | 10 ++++++++++ collects/compiler/zo-parse.rkt | 9 ++++++++- collects/compiler/zo-structs.rkt | 26 +++++++++++++++++++++++--- 3 files changed, 41 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 6e0d8ae475..29bff55b83 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -271,6 +271,7 @@ (define begin0-sequence-type-num 100) (define module-type-num 103) (define prefix-type-num 105) +(define free-id-info-type-num 154) (define-syntax define-enum (syntax-rules () @@ -446,6 +447,14 @@ (list->vector stxs))) out)])) +(define (out-free-id-info a-free-id-info out) + (match a-free-id-info + [(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?)) + (out-marshaled + free-id-info-type-num + (vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?) + out)])) + (define-struct module-decl (content)) (define (out-module mod-form out) @@ -954,6 +963,7 @@ [(prefix? expr) (out-prefix expr out)] [(global-bucket? expr) (out-toplevel expr out)] [(module-variable? expr) (out-toplevel expr out)] + [(free-id-info? expr) (out-free-id-info expr out)] [else (out-form expr out)])) (define (out-value expr out) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index e7adc72a82..3afd74e4d3 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -70,6 +70,11 @@ ; XXX Why not leave them as vectors and change the contract? (make-prefix i (vector->list tv) (vector->list sv))]))) +(define read-free-id-info + (match-lambda + [(vector mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0) ; I have no idea what these mean + (make-free-id-info mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0)])) + (define (read-unclosed-procedure v) (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) @@ -313,6 +318,7 @@ [(100) 'begin0-sequence-type] [(103) 'module-type] [(105) 'resolve-prefix-type] + [(154) 'free-id-info-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers @@ -333,7 +339,8 @@ (cons 'case-lambda-sequence-type read-case-lambda) (cons 'begin0-sequence-type read-sequence) (cons 'module-type read-module) - (cons 'resolve-prefix-type read-resolve-prefix)))) + (cons 'resolve-prefix-type read-resolve-prefix) + (cons 'free-id-info-type read-free-id-info)))) (define (get-reader type) (or (hash-ref type-readers type #f) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 8cc5042729..509a2dc7d5 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -169,9 +169,27 @@ ;; Top-level `require' (define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) -(define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name + +(define-form-struct free-id-info ([path0 module-path-index?] + [symbol0 symbol?] + [path1 module-path-index?] + [symbol1 symbol?] + [phase0 (or/c exact-integer? #f)] + [phase1 (or/c exact-integer? #f)] + [phase2 (or/c exact-integer? #f)] + [use-current-inspector? boolean?])) + +(define-form-struct (lexical-rename wrap) ([has-free-id-renames? boolean?] [bool2 boolean?] ; this needs a name - [alist any/c])) ; should be (listof (cons/c symbol? symbol?)) + [alist (listof + (cons/c symbol? + (or/c + symbol? + (cons/c + symbol? + (or/c + (cons/c symbol? (or/c symbol? #f)) + free-id-info?)))))])) (define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) (define-form-struct (wrap-mark wrap) ([val exact-integer?])) (define-form-struct (prune wrap) ([sym any/c])) @@ -179,7 +197,7 @@ (define-form-struct all-from-module ([path module-path-index?] [phase (or/c exact-integer? #f)] [src-phase any/c] ; should be (or/c exact-integer? #f) - [exceptions (or/c (listof symbol?) #f)] ; should be (listof symbol?) + [exceptions (or/c (listof (or/c symbol? number?)) #f)] ; should be (listof symbol?) [prefix (or/c (vector/c (or/c symbol? #f)) #f)])) ; should be (or/c symbol? #f) (define-form-struct nominal-path ()) @@ -226,3 +244,5 @@ + + From 4b9635cb70c38e6b7faee6140c2d09605d00f7fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Aug 2010 17:18:24 -0600 Subject: [PATCH 163/466] fix bytecode-writing inconsistencies related to syntax objects and paths and improve organization of the docs original commit: 0d9f5016ba98a7a7b9c83abddcfa3c02498a63fb --- collects/compiler/zo-marshal.rkt | 26 ++++++++++++++++++++++++-- collects/compiler/zo-parse.rkt | 18 +++++++++++++++++- 2 files changed, 41 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index f10a095f3b..da13079be1 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -8,7 +8,9 @@ racket/local racket/list racket/dict - racket/function) + racket/function + racket/pretty + racket/path) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -901,6 +903,7 @@ CPT_BYTE_STRING #f out)] + #; [(path? expr) (out-as-bytes expr path->bytes @@ -1024,7 +1027,20 @@ (if (quoted? expr) (out-data (quoted-v expr) out) (let ([s (open-output-bytes)]) - (write expr s) + ;; print `expr' to a string, but print paths + ;; in a special way + (parameterize ([pretty-print-size-hook + (lambda (v mode port) + (and (path? v) + (let ([v (make-relative v)]) + (+ 2 (let ([p (open-output-bytes)]) + (write (path->bytes v) p) + (bytes-length (get-output-bytes p)))))))] + [pretty-print-print-hook + (lambda (v mode port) + (display "#^" port) + (write (path->bytes (make-relative v)) port))]) + (pretty-write expr s)) (out-byte CPT_ESCAPE out) (let ([bstr (get-output-bytes s)]) (out-number (bytes-length bstr) out) @@ -1041,5 +1057,11 @@ (define-struct svector (vec)) +(define (make-relative v) + (let ([r (current-write-relative-directory)]) + (if r + (find-relative-path r v) + v))) + ;; ---------------------------------------- diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 3afd74e4d3..ed2541fdaf 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -732,7 +732,23 @@ [read-decimal-as-inexact #t] [read-accept-dot #t] [read-accept-infix-dot #t] - [read-accept-quasiquote #t]) + [read-accept-quasiquote #t] + ;; Use a readtable for special path support in escaped: + [current-readtable + (make-readtable + #f + #\^ + 'dispatch-macro + (lambda (char port src line col pos) + (let ([b (read port)]) + (unless (bytes? b) + (error 'read-escaped-path + "expected a byte string after #^")) + (let ([p (bytes->path b)]) + (if (and (relative-path? p) + (current-load-relative-directory)) + (build-path (current-load-relative-directory) p) + p)))))]) (read/recursive (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] From 03593e433bcd7610ef61a3908b9fdf290d4b8aa4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Aug 2010 14:48:22 -0600 Subject: [PATCH 164/466] teach decompiler about literal prims from `#%futures' original commit: 9be05599361316c9e01b6facaca9b8a66c6ab2f5 --- collects/compiler/decompile.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 6c8c75d4a4..b592d15776 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -16,6 +16,7 @@ (namespace-require ''#%kernel) (namespace-require ''#%unsafe) (namespace-require ''#%flfxnum) + (namespace-require ''#%futures) (for/list ([l (namespace-mapped-symbols)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))))))] From 9bebb5a98d70967ecb9f15af290e3ce2c31a047f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 16:10:55 -0400 Subject: [PATCH 165/466] Lots of "~e" to "~.s" changes. original commit: 606b7f60dc597a6870efc11364e1dd3e1a8b4a1b --- collects/compiler/zo-parse.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index ed2541fdaf..51b844e775 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -530,7 +530,7 @@ (match v [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] [`(,datum . ,wraps) (values #f datum wraps)] - [else (error 'decode-wraps "bad datum+wrap: ~e" v)])]) + [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) (let* ([wraps (decode-wraps cp encoded-wraps)] [marks (decode-marks cp cert-marks)] [add-wrap (lambda (v) (make-wrapped v wraps marks))]) From 33624300a8994fa6efbd5164ff7e754cbe911a67 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 17:16:32 -0400 Subject: [PATCH 166/466] Change a bunch of "~%" and "~n" in format strings to "\n". original commit: 7dc4d2e5a63ab416d90e44d7bf75cb5593329909 --- collects/tests/compiler/zo-test.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index dc4f49f939..1b1279eb36 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -203,21 +203,21 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (define succs (length (hash-ref success-ht kind-name empty))) (define all (+ fails succs)) (unless (zero? all) - (printf "~S~n" + (printf "~S\n" `(,kind-name (#f ,fails) (#t ,succs) ,all)))) (newline) - (printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty))) + (printf "~a tests passed\n" (length (hash-ref success-ht 'everything empty))) (let ([common-errors (sort (filter (λ (p) ((car p) . > . 10)) (hash-map errors (λ (k v) (cons v k)))) > #:key car)]) (unless (empty? common-errors) - (printf "Common Errors:~n") + (printf "Common Errors:\n") (for ([p (in-list common-errors)]) - (printf "~a:~n~a~n~n" (car p) (cdr p))))))))) + (printf "~a:\n~a\n\n" (car p) (cdr p))))))))) -(thread-wait final-thread) \ No newline at end of file +(thread-wait final-thread) From f38ec26ea5df762525ac575f860285923f7c69e3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 26 Aug 2010 12:10:48 -0400 Subject: [PATCH 167/466] More "~n" -> "\n" changes original commit: 8e0f8dd39c3744472b450021f003f9cbe8cbcb62 --- collects/tests/racket/embed-me1.rkt | 2 +- collects/tests/racket/embed-me1b.rkt | 2 +- collects/tests/racket/embed-me1c.rkt | 2 +- collects/tests/racket/embed-me1d.rkt | 2 +- collects/tests/racket/embed-me1e.rkt | 2 +- collects/tests/racket/embed-me2.rkt | 5 +---- collects/tests/racket/embed.rktl | 2 +- 7 files changed, 7 insertions(+), 10 deletions(-) diff --git a/collects/tests/racket/embed-me1.rkt b/collects/tests/racket/embed-me1.rkt index 7e2bb11748..65f7030bb1 100644 --- a/collects/tests/racket/embed-me1.rkt +++ b/collects/tests/racket/embed-me1.rkt @@ -1,5 +1,5 @@ (module embed-me1 mzscheme (with-output-to-file "stdout" - (lambda () (printf "This is 1~n")) + (lambda () (printf "This is 1\n")) 'append)) diff --git a/collects/tests/racket/embed-me1b.rkt b/collects/tests/racket/embed-me1b.rkt index 5af91026b6..5c2ae8fce6 100644 --- a/collects/tests/racket/embed-me1b.rkt +++ b/collects/tests/racket/embed-me1b.rkt @@ -4,6 +4,6 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "icons/file.gif")) (with-output-to-file "stdout" - (lambda () (printf "This is 1b~n")) + (lambda () (printf "This is 1b\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me1c.rkt b/collects/tests/racket/embed-me1c.rkt index 067c8ad230..70c8a943c8 100644 --- a/collects/tests/racket/embed-me1c.rkt +++ b/collects/tests/racket/embed-me1c.rkt @@ -4,6 +4,6 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "etc.ss")) ; in mzlib (with-output-to-file "stdout" - (lambda () (printf "This is 1c~n")) + (lambda () (printf "This is 1c\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me1d.rkt b/collects/tests/racket/embed-me1d.rkt index cc6b750193..7bc3cd2149 100644 --- a/collects/tests/racket/embed-me1d.rkt +++ b/collects/tests/racket/embed-me1d.rkt @@ -4,5 +4,5 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "file.gif" "icons")) (with-output-to-file "stdout" - (lambda () (printf "This is 1d~n")) + (lambda () (printf "This is 1d\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me1e.rkt b/collects/tests/racket/embed-me1e.rkt index 645df59905..8ad79cff45 100644 --- a/collects/tests/racket/embed-me1e.rkt +++ b/collects/tests/racket/embed-me1e.rkt @@ -4,5 +4,5 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "html")) (with-output-to-file "stdout" - (lambda () (printf "This is 1e~n")) + (lambda () (printf "This is 1e\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me2.rkt b/collects/tests/racket/embed-me2.rkt index 53abb21299..0e4d9481dd 100644 --- a/collects/tests/racket/embed-me2.rkt +++ b/collects/tests/racket/embed-me2.rkt @@ -2,8 +2,5 @@ (require "embed-me1.ss" mzlib/etc) (with-output-to-file "stdout" - (lambda () (printf "This is 2: ~a~n" true)) + (lambda () (printf "This is 2: ~a\n" true)) 'append)) - - - diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 457f2ea6b4..f959ec7031 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -37,7 +37,7 @@ (mk-dest-bin #t))) (define (prepare exe src) - (printf "Making ~a with ~a...~n" exe src) + (printf "Making ~a with ~a...\n" exe src) (when (file-exists? exe) (delete-file exe))) From 1b3843bd9cb6e4cb8fe79e4daf6742633f5c7360 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Aug 2010 09:17:21 -0600 Subject: [PATCH 168/466] fix yet more ss<->rkt problems that interfered with *SL executables Closes PR 11106 original commit: 76c3c7621405d189993fa8935de2c6688567700f --- collects/tests/racket/embed-me12-rd.ss | 15 +++++++++++++ collects/tests/racket/embed.rktl | 30 ++++++++++++++++++++------ 2 files changed, 38 insertions(+), 7 deletions(-) create mode 100644 collects/tests/racket/embed-me12-rd.ss diff --git a/collects/tests/racket/embed-me12-rd.ss b/collects/tests/racket/embed-me12-rd.ss new file mode 100644 index 0000000000..682396a20b --- /dev/null +++ b/collects/tests/racket/embed-me12-rd.ss @@ -0,0 +1,15 @@ +(module embed-me11-rd mzscheme + (provide (rename *read-syntax read-syntax) + (rename *read read)) + + (define (*read port) + `(module embed-me11 mzscheme + (with-output-to-file "stdout" + (lambda () + (printf ,(read port) + ;; Use `getenv' at read time!!! + ,(getenv "ELEVEN"))) + 'append))) + + (define (*read-syntax src port) + (*read port))) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index f959ec7031..25924e8f06 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -397,23 +397,36 @@ ;; Try including source that needs a reader extension -(define (try-reader-test mred?) +(define (try-reader-test 12? mred? ss-file? ss-reader?) + ;; actual "11" files use ".rkt", actual "12" files use ".ss" (define dest (mk-dest mred?)) - (define filename "embed-me11.rkt") + (define filename (format (if ss-file? + "embed-me~a.ss" + "embed-me~a.rkt") + (if 12? "12" "11"))) (define (flags s) (string-append "-" s)) + (printf "Trying ~s ~s ~s ~s...\n" (if 12? "12" "11") mred? ss-file? ss-reader?) + (create-embedding-executable dest #:modules `((#t (lib ,filename "tests" "racket"))) #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) - (equal? name (string->path filename)))) + (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))))) #:get-extra-imports (lambda (f code) (let-values ([(base name dir?) (split-path f)]) - (if (equal? name (string->path filename)) - '((lib "embed-me11-rd.rkt" "tests" "racket")) + (if (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))) + `((lib ,(format (if ss-reader? + "embed-me~a-rd.ss" + "embed-me~a-rd.rkt") + (if 12? "12" "11")) + "tests" + "racket")) null))) #:mred? mred?) @@ -422,8 +435,11 @@ (putenv "ELEVEN" "done")) (define (try-reader) - (try-reader-test #f) - (try-reader-test #t)) + (for ([12? (in-list '(#f #t))]) + (try-reader-test 12? #f #f #f) + (try-reader-test 12? #t #f #f) + (try-reader-test 12? #f #t #f) + (try-reader-test 12? #f #f #t))) ;; ---------------------------------------- From 1d54bf17a5072833da2e57d8e622f2bc64c855df Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 17 Aug 2010 12:09:05 -0600 Subject: [PATCH 169/466] zo-parse debugging and read in zo-exs original commit: f27fe3d5c9941e536275d0f56cb02d6df16ac283 --- collects/compiler/zo-parse.rkt | 15 +++++++++----- collects/tests/compiler/zo-exs.rkt | 33 +++++++++++++++++------------- 2 files changed, 29 insertions(+), 19 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 51b844e775..b7889fe291 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -709,10 +709,11 @@ (let loop ([need-car 0] [proper #f]) (begin-with-definitions (define ch (cp-getc cp)) - (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) - (unless x - (error 'read-compact "unknown code : ~a" ch)) - (values (car x) (cdr x)))) + (define-values (cpt-start cpt-tag) + (let ([x (cpt-table-lookup ch)]) + (unless x + (error 'read-compact "unknown code : ~a" ch)) + (values (car x) (cdr x)))) (define v (case cpt-tag [(delayed) @@ -1004,8 +1005,12 @@ (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) - (for/list ([i (in-range 1 symtabsize)]) + (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + + #;(for ([i (in-naturals)] + [v (in-vector (cport-symtab cp))]) + (printf "~a: ~s~n~n" i (placeholder-get v))) (set-cport-pos! cp shared-size) (make-reader-graph (read-marshalled 'compilation-top-type cp)))) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 75aea4d252..8fd5d3ee47 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -3,12 +3,28 @@ compiler/zo-marshal tests/eli-tester) +(define (read-compiled-bytes bs) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes bs)))) + (define (roundtrip ct) (define bs (zo-marshal ct)) - (test bs - (zo-parse (open-input-bytes bs)) => ct)) + (test #:failure-prefix (format "~S" ct) + (test bs + (zo-parse (open-input-bytes bs)) => ct + (read-compiled-bytes bs)))) (test + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (current-directory))) + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list (current-directory)))) + (local [(define (hash-test make-hash-placeholder) (roundtrip (compilation-top 0 @@ -19,17 +35,6 @@ (make-reader-graph ht)))))] (hash-test make-hash-placeholder) (hash-test make-hasheq-placeholder) - (hash-test make-hasheqv-placeholder)) - - - (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (current-directory))) - - (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (list (current-directory))))) + (hash-test make-hasheqv-placeholder))) From 817b3186d97d73a77b90712a7b2973cdbbb2c030 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 19 Aug 2010 12:33:31 -0600 Subject: [PATCH 170/466] zo-marshal single out-anything function and zo-parse debugging original commit: 37f07cb68b504ed1e80853c899ef710cbf60188d --- collects/compiler/zo-marshal.rkt | 1117 ++++++++++++++---------------- collects/compiler/zo-parse.rkt | 397 ++++++----- 2 files changed, 738 insertions(+), 776 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index da13079be1..fa3be595e9 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -8,9 +8,7 @@ racket/local racket/list racket/dict - racket/function - racket/pretty - racket/path) + racket/function) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -24,8 +22,8 @@ (define (zo-marshal-to top outp) (match top [(struct compilation-top (max-let-depth prefix form)) - (define shared (make-hasheq)) - (define wrapped (make-hasheq)) + (define shared (make-hash)) + (define wrapped (make-hash)) (define (shared-obj-pos v) (hash-ref shared v #f)) (define (share! v) @@ -34,13 +32,15 @@ (list* max-let-depth prefix (protect-quote form))) ; Compute what objects are in ct multiple times (by equal?) - (local [(define encountered (make-hasheq)) + (local [(define encountered (make-hash)) (define (encountered? v) (hash-ref encountered v #f)) (define (encounter! v) (hash-set! encountered v #t)) (define (visit! v) (cond + [(not (shareable? v)) + #t] [(shared-obj-pos v) #f] [(encountered? v) @@ -86,8 +86,8 @@ ; Compute where we ended (define post-shared (file-position outp)) ; Write the entire ctop - (out-data ct - (make-out outp shared-obj-pos wrapped)) + (out-anything ct + (make-out outp shared-obj-pos wrapped)) (values offsets post-shared (file-position outp))) ; Compute where the symbol table ends @@ -277,18 +277,146 @@ (define-struct case-seq (name lams)) (define-struct (seq0 seq) ()) + +(define (encode-module-bindings module-bindings) + (define encode-nominal-path + (match-lambda + [(struct simple-nominal-path (value)) + value] + [(struct imported-nominal-path (value import-phase)) + (cons value import-phase)] + [(struct phased-nominal-path (value import-phase phase)) + (cons value (cons import-phase phase))])) + (define encoded-bindings (make-vector (* (length module-bindings) 2))) + (for ([i (in-naturals)] + [(k v) (in-dict module-bindings)]) + (vector-set! encoded-bindings (* i 2) k) + (vector-set! encoded-bindings (add1 (* i 2)) + (match v + [(struct simple-module-binding (path)) + path] + [(struct exported-module-binding (path export-name)) + (cons path export-name)] + [(struct nominal-module-binding (path nominal-path)) + (cons path (encode-nominal-path nominal-path))] + [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) + (list* path export-name (encode-nominal-path nominal-path) nominal-export-name)] + [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) + (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) + encoded-bindings) + +(define encode-all-from-module + (match-lambda + [(struct all-from-module (path phase src-phase #f #f)) + (list* path phase src-phase)] + [(struct all-from-module (path phase src-phase exns #f)) + (list* path phase exns src-phase)] + [(struct all-from-module (path phase src-phase exns (vector prefix))) + (list* path phase src-phase exns prefix)])) + +(define (encode-wraps wraps) + (for/list ([wrap (in-list wraps)]) + (match wrap + [(struct phase-shift (amt src dest)) + (box (vector amt src dest #f))] + [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) + (define encoded-kind (eq? kind 'marked)) + (define encoded-unmarshals (map encode-all-from-module unmarshals)) + (define encoded-renames (encode-module-bindings renames)) + (define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals) + (values encoded-renames mark-renames) + (values encoded-unmarshals (cons encoded-renames mark-renames)))) + (define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames)) + (if plus-kern? + (cons #t mod-rename) + mod-rename)] + [(struct lexical-rename (bool1 bool2 alist)) + (define len (length alist)) + (define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning + (vector-set! vec 0 bool1) + (vector-set! vec 1 bool2) + (for ([(k v) (in-dict alist)] + [i (in-naturals)]) + (vector-set! vec (+ 2 i) k) + (vector-set! vec (+ 2 i len) v)) + vec] + [(struct top-level-rename (flag)) + flag] + [(struct mark-barrier (value)) + value] + [(struct prune (syms)) + (box syms)] + [(struct wrap-mark (val)) + (list val)]))) + +(define (encode-mark-map mm) + mm + #;(for/fold ([l empty]) + ([(k v) (in-hash ht)]) + (list* k v l))) + +(define-struct protected-symref (val)) + +(define encode-certs + (match-lambda + [(struct certificate:nest (m1 m2)) + (list* (encode-mark-map m1) (encode-mark-map m2))] + [(struct certificate:ref (val m)) + (list* #f (make-protected-symref val) (encode-mark-map m))])) + +(define (encode-wrapped w) + (match w + [(struct wrapped (datum wraps certs)) + (let* ([enc-datum + (match datum + [(cons a b) + (let ([p (cons (encode-wrapped a) + (let bloop ([b b]) + (match b + ['() null] + [(cons b1 b2) + (cons (encode-wrapped b1) + (bloop b2))] + [else + (encode-wrapped b)])))] + ; XXX Cylic list error possible + [len (let loop ([datum datum][len 0]) + (cond + [(null? datum) #f] + [(pair? datum) (loop (cdr datum) (add1 len))] + [else len]))]) + ;; for improper lists, we need to include the length so the + ;; parser knows where the end of the improper list is + (if len + (cons len p) + p))] + [(box x) + (box (encode-wrapped x))] + [(? vector? v) + (vector-map encode-wrapped v)] + [(? prefab-struct-key) + (define l (vector->list (struct->vector datum))) + (apply + make-prefab-struct + (car l) + (map encode-wrapped (cdr l)))] + [_ datum])] + [p (cons enc-datum + (encode-wraps wraps))]) + (if certs + (vector p (encode-certs certs)) + p))])) + (define-struct out (s shared-index encoded-wraps)) (define (out-shared v out k) - (let ([v ((out-shared-index out) v)]) - (if v - (begin - (out-byte CPT_SYMREF out) - (out-number v out)) - (k)))) -(define (display-byte b) - (if (b . <= . #xf) - (printf "0~x" b) - (printf "~x" b))) + (if (shareable? v) + (let ([v ((out-shared-index out) v)]) + (if v + (begin + (out-byte CPT_SYMREF out) + (out-number v out)) + (k))) + (k))) (define (out-byte v out) (write-byte v (out-s out))) @@ -322,34 +450,375 @@ (begin (out-byte CPT_MARSHALLED out) (out-number type-num out))) - (out-data val out)) + (out-anything val out)) + +(define (or-pred? v . ps) + (ormap (lambda (?) (? v)) ps)) + +(define (shareable? v) + (not (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?))) + +(define (maybe-same-as-fixnum? v) + (and (exact-integer? v) + (and (v . >= . -1073741824) (v . <= . 1073741823)))) (define (out-anything v out) - (cond - [(module-variable? v) - (out-toplevel v out)] - [(closure? v) - (out-expr v out)] - [else - (out-data v out)])) - -(define (out-prefix a-prefix out) - (match a-prefix - [(struct prefix (num-lifts toplevels stxs)) - (out-marshaled - prefix-type-num - (cons num-lifts - (cons (list->vector toplevels) - (list->vector stxs))) - out)])) - -(define (out-free-id-info a-free-id-info out) - (match a-free-id-info - [(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?)) - (out-marshaled - free-id-info-type-num - (vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?) - out)])) + (out-shared + v out + (λ () + (match v + [(? char?) + (out-byte CPT_CHAR out) + (out-number (char->integer v) out)] + [(? maybe-same-as-fixnum?) ;XXX not sure if it's okay to use fixnum? instead of exact range check + (if (and (v . >= . 0) + (v . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) + (out-byte (+ CPT_SMALL_NUMBER_START v) out) + (begin + (out-byte CPT_INT out) + (out-number v out)))] + [(list) + (out-byte CPT_NULL out)] + [#t + (out-byte CPT_TRUE out)] + [#f + (out-byte CPT_FALSE out)] + [(? void?) + (out-byte CPT_VOID out)] + [(struct module-variable (modidx sym pos phase)) + (out-byte CPT_MODULE_VAR out) + (out-anything modidx out) + (out-anything sym out) + (unless (zero? phase) + (out-number -2 out)) + (out-number pos out)] + [(struct indirect (val)) (out-anything val out)] + [(struct closure (lam gen-id)) + (out-byte CPT_CLOSURE out) + (out-number ((out-shared-index out) v) out) + (out-anything lam out)] + [(struct prefix (num-lifts toplevels stxs)) + (out-marshaled + prefix-type-num + (cons num-lifts + (cons (list->vector toplevels) + (list->vector stxs))) + out)] + [(struct global-bucket (name)) + (out-marshaled variable-type-num name out)] + [(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?)) + (out-marshaled + free-id-info-type-num + (vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?) + out)] + [(? mod?) + (out-module v out)] + [(struct def-values (ids rhs)) + (out-syntax DEFINE_VALUES_EXPD + (list->vector (cons (protect-quote rhs) ids)) + out)] + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_SYNTAX_EXPD + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_FOR_SYNTAX_EXPD + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct seq0 (forms)) + (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] + [(struct seq (forms)) + (out-marshaled sequence-type-num (map protect-quote forms) out)] + [(struct splice (forms)) + (out-syntax SPLICE_EXPD (make-seq forms) out)] + [(struct req (reqs dummy)) + (error "cannot handle top-level `require', yet") + (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] + [(struct toplevel (depth pos const? ready?)) + (out-marshaled toplevel-type-num + (cons + depth + (if (or const? ready?) + (cons pos + (bitwise-ior + (if const? #x1 0) + (if ready? #x2 0))) + pos)) + out)] + [(struct topsyntax (depth pos midpt)) + (out-marshaled quote-syntax-type-num + (cons depth + (cons pos midpt)) + out)] + [(struct primval (id)) + (out-byte CPT_REFERENCE out) + (out-number id out)] + [(struct assign (id rhs undef-ok?)) + (out-syntax SET_EXPD + (cons undef-ok? (cons id rhs)) + out)] + [(struct localref (unbox? offset clear? other-clears? flonum?)) + (if (and (not clear?) (not other-clears?) (not flonum?) + (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) + (out-byte (+ (if unbox? + CPT_SMALL_LOCAL_UNBOX_START + CPT_SMALL_LOCAL_START) + offset) + out) + (begin + (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) + (if (not (or clear? other-clears? flonum?)) + (out-number offset out) + (begin + (out-number (- (add1 offset)) out) + (out-number (if clear? + #x1 + (if other-clears? + #x2 + (if flonum? + #x3 + 0))) + out)))))] + [(? lam?) + (out-lam v out)] + [(struct case-lam (name lams)) + (let ([seq (make-case-seq name lams)]) + ;; XXX: This seems like an optimization, which should probably happen somewhere else + ;; If all closures are empty, generate a case sequence directly + (if (andmap (lambda (lam) + (or (closure? lam) + (and (lam? lam) + (equal? (lam-closure-map lam) #())))) + lams) + (out-anything seq out) + (out-syntax CASE_LAMBDA_EXPD + seq + out)))] + [(struct case-seq (name lams)) + (out-marshaled case-lambda-sequence-type-num + (cons (or name null) + lams) + out)] + [(struct let-one (rhs body flonum? unused?)) + (out-byte (cond + [flonum? CPT_LET_ONE_FLONUM] + [unused? CPT_LET_ONE_UNUSED] + [else CPT_LET_ONE]) + out) + (out-anything (protect-quote rhs) out) + (out-anything (protect-quote body) out)] + [(struct let-void (count boxes? body)) + (out-marshaled let-void-type-num + (list* + count + boxes? + (protect-quote body)) + out)] + [(struct let-rec (procs body)) + (out-marshaled letrec-type-num + (list* + (length procs) + (protect-quote body) + procs) + out)] + [(struct install-value (count pos boxes? rhs body)) + (out-marshaled let-value-type-num + (list* + count + pos + boxes? + (protect-quote rhs) + (protect-quote body)) + out)] + [(struct boxenv (pos body)) + (out-syntax BOXENV_EXPD + (cons + pos + (protect-quote body)) + out)] + [(struct branch (test then else)) + (out-byte CPT_BRANCH out) + (out-anything (protect-quote test) out) + (out-anything (protect-quote then) out) + (out-anything (protect-quote else) out)] + [(struct application (rator rands)) + (let ([len (length rands)]) + (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) + (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) + (begin + (out-byte CPT_APPLICATION out) + (out-number len out))) + (for-each (lambda (e) (out-anything (protect-quote e) out)) + (cons rator rands)))] + [(struct apply-values (proc args-expr)) + (out-syntax APPVALS_EXPD + (cons (protect-quote proc) + (protect-quote args-expr)) + out)] + [(struct beg0 (exprs)) + (out-syntax BEGIN0_EXPD + (make-seq0 exprs) + out)] + [(struct with-cont-mark (key val body)) + (out-marshaled wcm-type-num + (list* + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] + [(struct varref (expr)) + (out-syntax REF_EXPD + expr + out)] + [(protected-symref v) + (out-anything ((out-shared-index out) v) out)] + [(and (? symbol?) (not (? symbol-interned?))) + (out-as-bytes v + #:before-length (if (symbol-unreadable? v) 0 1) + (compose string->bytes/utf-8 symbol->string) + CPT_WEIRD_SYMBOL + #f + out)] + [(? symbol?) + (define bs (string->bytes/utf-8 (symbol->string v))) + (define len (bytes-length bs)) + (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) + (out-byte (+ CPT_SMALL_SYMBOL_START len) out) + (begin (out-byte CPT_SYMBOL out) + (out-number len out))) + (out-bytes bs out)] + [(? keyword?) + (out-as-bytes v + (compose string->bytes/utf-8 keyword->string) + CPT_KEYWORD + #f + out)] + [(? string?) + (out-as-bytes v + string->bytes/utf-8 + CPT_CHAR_STRING + (string-length v) + out)] + [(? bytes?) + (out-as-bytes v + values + CPT_BYTE_STRING + #f + out)] + [(? box?) + (out-byte CPT_BOX out) + (out-anything (unbox v) out)] + [(? pair?) + (define (list-length-before-cycle/improper-end l) + (let loop ([len 1] [l (cdr l)]) + (cond + [((out-shared-index out) l) + (values len #f)] + [(null? l) + (values len #t)] + [(pair? l) + (loop (add1 len) (cdr l))] + [else + (values len #f)]))) + (define-values (len proper?) (list-length-before-cycle/improper-end v)) + (define (print-contents-as-proper) + (for ([e (in-list v)]) + (out-anything e out))) + (define (print-contents-as-improper) + (let loop ([l v] [i len]) + (cond + [(zero? i) + (out-anything l out)] + [else + (out-anything (car l) out) + (loop (cdr l) (sub1 i))]))) + (if proper? + (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) + (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) + (print-contents-as-proper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-proper) + (out-anything null out))) + (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) + ; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR + (begin (out-byte (+ CPT_SMALL_LIST_START len) out) + (print-contents-as-improper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-improper))))] + [(? vector?) + (out-byte CPT_VECTOR out) + (out-number (vector-length v) out) + (for ([v (in-vector v)]) + (out-anything v out))] + [(? hash?) + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? v) 2] + [(hash-eq? v) 0] + [else 1]) + out) + (out-number (hash-count v) out) + (for ([(k v) (in-hash v)]) + (out-anything k out) + (out-anything v out))] + [(svector vec) + (let* ([len (vector-length vec)]) + (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) + (out-byte (+ CPT_SMALL_SVECTOR_START len) out) + (begin (out-byte CPT_SVECTOR out) + (out-number len out))) + (for ([n (in-range (sub1 len) -1 -1)]) + (out-number (vector-ref vec n) out)))] + [(? module-path-index?) + (out-byte CPT_MODULE_INDEX out) + (let-values ([(name base) (module-path-index-split v)]) + (out-anything name out) + (out-anything base out))] + [(module-decl content) + (out-marshaled module-type-num + content + out)] + [(stx encoded) + (out-byte CPT_STX out) + (out-anything encoded out)] + [(? wrapped?) + (out-anything (lookup-encoded-wrapped v out) out)] + [(? prefab-struct-key) + (define pre-v (struct->vector v)) + (vector-set! pre-v 0 (prefab-struct-key v)) + (out-byte CPT_PREFAB out) + (out-anything pre-v out)] + [else + (out-byte CPT_QUOTE out) + (if (quoted? v) + (out-anything (quoted-v v) out) + (let ([s (open-output-bytes)]) + (parameterize ([pretty-print-size-hook + (lambda (v mode port) + (and (path? v) + (let ([v (make-relative v)]) + (+ 2 (let ([p (open-output-bytes)]) + (write (path->bytes v) p) + (bytes-length (get-output-bytes p)))))))] + [pretty-print-print-hook + (lambda (v mode port) + (display "#^" port) + (write (path->bytes (make-relative v)) port))]) + (pretty-write expr s)) + (out-byte CPT_ESCAPE out) + (let ([bstr (get-output-bytes s)]) + (out-number (bytes-length bstr) out) + (out-bytes bstr out))))])))) (define-struct module-decl (content)) @@ -444,361 +913,15 @@ (make-module-decl l)) out)])) -(define (out-toplevel tl out) - (match tl - [#f (out-data tl out)] - [(? symbol?) (out-data tl out)] - [(struct global-bucket (name)) - (out-marshaled variable-type-num name out)] - [(struct module-variable (modidx sym pos phase)) - (out-shared - tl - out - (lambda () - (out-byte CPT_MODULE_VAR out) - (out-data modidx out) - (out-data sym out) - (unless (zero? phase) - (out-number -2 out)) - (out-number pos out)))])) - -(define (encode-module-bindings module-bindings) - (define encode-nominal-path - (match-lambda - [(struct simple-nominal-path (value)) - value] - [(struct imported-nominal-path (value import-phase)) - (cons value import-phase)] - [(struct phased-nominal-path (value import-phase phase)) - (cons value (cons import-phase phase))])) - (define encoded-bindings (make-vector (* (length module-bindings) 2))) - (for ([i (in-naturals)] - [(k v) (in-dict module-bindings)]) - (vector-set! encoded-bindings (* i 2) k) - (vector-set! encoded-bindings (add1 (* i 2)) - (match v - [(struct simple-module-binding (path)) - path] - [(struct exported-module-binding (path export-name)) - (cons path export-name)] - [(struct nominal-module-binding (path nominal-path)) - (cons path (encode-nominal-path nominal-path))] - [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) - (list* path export-name (encode-nominal-path nominal-path) nominal-export-name)] - [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) - (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) - encoded-bindings) - -(define encode-all-from-module - (match-lambda - [(struct all-from-module (path phase src-phase #f #f)) - (list* path phase src-phase)] - [(struct all-from-module (path phase src-phase exns #f)) - (list* path phase exns src-phase)] - [(struct all-from-module (path phase src-phase exns (vector prefix))) - (list* path phase src-phase exns prefix)])) - -(define (encode-wraps wraps) - (for/list ([wrap (in-list wraps)]) - (match wrap - [(struct phase-shift (amt src dest)) - (box (vector amt src dest #f))] - [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) - (define encoded-kind (eq? kind 'marked)) - (define encoded-unmarshals (map encode-all-from-module unmarshals)) - (define encoded-renames (encode-module-bindings renames)) - (define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals) - (values encoded-renames mark-renames) - (values encoded-unmarshals (cons encoded-renames mark-renames)))) - (define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames)) - (if plus-kern? - (cons #t mod-rename) - mod-rename)] - [(struct lexical-rename (bool1 bool2 alist)) - (define len (length alist)) - (define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning - (vector-set! vec 0 bool1) - (vector-set! vec 1 bool2) - (for ([(k v) (in-dict alist)] - [i (in-naturals)]) - (vector-set! vec (+ 2 i) k) - (vector-set! vec (+ 2 i len) v)) - vec] - [(struct top-level-rename (flag)) - flag] - [(struct mark-barrier (value)) - value] - [(struct prune (syms)) - (box syms)] - [(struct wrap-mark (val)) - (list val)]))) - -(define (encode-mark-map mm) - mm - #;(for/fold ([l empty]) - ([(k v) (in-hash ht)]) - (list* k v l))) - -(define-struct protected-symref (val)) - -(define encode-certs - (match-lambda - [(struct certificate:nest (m1 m2)) - (list* (encode-mark-map m1) (encode-mark-map m2))] - [(struct certificate:ref (val m)) - (list* #f (make-protected-symref val) (encode-mark-map m))])) - -(define (encode-wrapped w) - (match w - [(struct wrapped (datum wraps certs)) - (let* ([enc-datum - (match datum - [(cons a b) - (let ([p (cons (encode-wrapped a) - (let bloop ([b b]) - (match b - ['() null] - [(cons b1 b2) - (cons (encode-wrapped b1) - (bloop b2))] - [else - (encode-wrapped b)])))] - ; XXX Cylic list error possible - [len (let loop ([datum datum][len 0]) - (cond - [(null? datum) #f] - [(pair? datum) (loop (cdr datum) (add1 len))] - [else len]))]) - ;; for improper lists, we need to include the length so the - ;; parser knows where the end of the improper list is - (if len - (cons len p) - p))] - [(box x) - (box (encode-wrapped x))] - [(? vector? v) - (vector-map encode-wrapped v)] - [(? prefab-struct-key) - (define l (vector->list (struct->vector datum))) - (apply - make-prefab-struct - (car l) - (map encode-wrapped (cdr l)))] - [_ datum])] - [p (cons enc-datum - (encode-wraps wraps))]) - (if certs - (vector p (encode-certs certs)) - p))])) (define (lookup-encoded-wrapped w out) (hash-ref (out-encoded-wraps out) w (lambda () (error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w)))) -(define (out-wrapped w out) - (out-data (lookup-encoded-wrapped w out) out)) - -(define (out-stx s out) - (out-shared s out - (lambda () - (match s - [(struct stx (encoded)) - (out-byte CPT_STX out) - (out-wrapped encoded out)])))) - -(define (out-form form out) - (match form - [(? mod?) - (out-module form out)] - [(struct def-values (ids rhs)) - (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons (protect-quote rhs) ids)) - out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct seq0 (forms)) - (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] - [(struct seq (forms)) - (out-marshaled sequence-type-num (map protect-quote forms) out)] - [(struct splice (forms)) - (out-syntax SPLICE_EXPD (make-seq forms) out)] - [(struct req (reqs dummy)) - (error "cannot handle top-level `require', yet") - (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] - [else - (out-expr form out)])) - -(define (out-expr expr out) - (match expr - [(struct toplevel (depth pos const? ready?)) - (out-marshaled toplevel-type-num - (cons - depth - (if (or const? ready?) - (cons pos - (bitwise-ior - (if const? #x1 0) - (if ready? #x2 0))) - pos)) - out)] - [(struct topsyntax (depth pos midpt)) - (out-marshaled quote-syntax-type-num - (cons depth - (cons pos midpt)) - out)] - [(struct primval (id)) - (out-byte CPT_REFERENCE out) - (out-number id out)] - [(struct assign (id rhs undef-ok?)) - (out-syntax SET_EXPD - (cons undef-ok? (cons id rhs)) - out)] - [(struct localref (unbox? offset clear? other-clears? flonum?)) - (if (and (not clear?) (not other-clears?) (not flonum?) - (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) - (out-byte (+ (if unbox? - CPT_SMALL_LOCAL_UNBOX_START - CPT_SMALL_LOCAL_START) - offset) - out) - (begin - (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears? flonum?)) - (out-number offset out) - (begin - (out-number (- (add1 offset)) out) - (out-number (if clear? - #x1 - (if other-clears? - #x2 - (if flonum? - #x3 - 0))) - out)))))] - [(? lam?) - (out-lam expr out)] - [(struct case-lam (name lams)) - (let ([seq (make-case-seq name lams)]) - ;; If all closures are empy, generate a case sequence directly - (if (andmap (lambda (lam) - (or (closure? lam) - (and (lam? lam) - (equal? (lam-closure-map lam) #())))) - lams) - (out-data seq out) - (out-syntax CASE_LAMBDA_EXPD - seq - out)))] - [(struct case-seq (name lams)) - (out-marshaled case-lambda-sequence-type-num - (cons (or name null) - lams) - out)] - [(struct let-one (rhs body flonum? unused?)) - (out-byte (cond - [flonum? CPT_LET_ONE_FLONUM] - [unused? CPT_LET_ONE_UNUSED] - [else CPT_LET_ONE]) - out) - (out-expr (protect-quote rhs) out) - (out-expr (protect-quote body) out)] - [(struct let-void (count boxes? body)) - (out-marshaled let-void-type-num - (list* - count - boxes? - (protect-quote body)) - out)] - [(struct let-rec (procs body)) - (out-marshaled letrec-type-num - (list* - (length procs) - (protect-quote body) - procs) - out)] - [(struct install-value (count pos boxes? rhs body)) - (out-marshaled let-value-type-num - (list* - count - pos - boxes? - (protect-quote rhs) - (protect-quote body)) - out)] - [(struct boxenv (pos body)) - (out-syntax BOXENV_EXPD - (cons - pos - (protect-quote body)) - out)] - [(struct branch (test then else)) - (out-byte CPT_BRANCH out) - (out-expr (protect-quote test) out) - (out-expr (protect-quote then) out) - (out-expr (protect-quote else) out)] - [(struct application (rator rands)) - (let ([len (length rands)]) - (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) - (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) - (begin - (out-byte CPT_APPLICATION out) - (out-number len out))) - (for-each (lambda (e) (out-expr (protect-quote e) out)) - (cons rator rands)))] - [(struct apply-values (proc args-expr)) - (out-syntax APPVALS_EXPD - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] - [(struct seq (exprs)) - (out-form expr out)] - [(struct beg0 (exprs)) - (out-syntax BEGIN0_EXPD - (make-seq0 exprs) - out)] - [(struct with-cont-mark (key val body)) - (out-marshaled wcm-type-num - (list* - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] - [(struct closure (lam gen-id)) - (out-lam expr out)] - [(struct indirect (val)) - (out-expr val out)] - [(struct varref (expr)) - (out-syntax REF_EXPD - expr - out)] - [else (out-value expr out)])) (define (out-lam expr out) (match expr - [(struct indirect (val)) (out-lam val out)] - [(struct closure (lam gen-id)) - (out-shared - expr - out - (lambda () - (out-byte CPT_CLOSURE out) - (out-number ((out-shared-index out) expr) out) - (out-lam lam out)))] [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) (let* ([l (protect-quote body)] [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) @@ -845,207 +968,13 @@ out))])) (define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f]) - (out-shared expr out (lambda () - (let ([s (->bytes expr)]) - (out-byte CPT out) - (when before-length - (out-number before-length out)) - (out-number (bytes-length s) out) - (when len2 (out-number len2 out)) - (out-bytes s out))))) - -(define (out-data expr out) - (cond - [(prefix? expr) (out-prefix expr out)] - [(global-bucket? expr) (out-toplevel expr out)] - [(module-variable? expr) (out-toplevel expr out)] - [(free-id-info? expr) (out-free-id-info expr out)] - [else (out-form expr out)])) - -(define (out-value expr out) - (cond - [(protected-symref? expr) - (let* ([val (protected-symref-val expr)] - [val-ref ((out-shared-index out) val)]) - (out-value val-ref out))] - [(and (symbol? expr) (not (symbol-interned? expr))) - (out-as-bytes expr - #:before-length (if (symbol-unreadable? expr) 0 1) - (compose string->bytes/utf-8 symbol->string) - CPT_WEIRD_SYMBOL - #f - out)] - [(symbol? expr) - (out-shared expr out - (lambda () - (define bs (string->bytes/utf-8 (symbol->string expr))) - (define len (bytes-length bs)) - (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) - (out-byte (+ CPT_SMALL_SYMBOL_START len) out) - (begin (out-byte CPT_SYMBOL out) - (out-number len out))) - (out-bytes bs out)))] - [(keyword? expr) - (out-as-bytes expr - (compose string->bytes/utf-8 keyword->string) - CPT_KEYWORD - #f - out)] - [(string? expr) - (out-as-bytes expr - string->bytes/utf-8 - CPT_CHAR_STRING - (string-length expr) - out)] - [(bytes? expr) - (out-as-bytes expr - values - CPT_BYTE_STRING - #f - out)] - #; - [(path? expr) - (out-as-bytes expr - path->bytes - CPT_PATH - #f - out)] - [(char? expr) - (out-byte CPT_CHAR out) - (out-number (char->integer expr) out)] - [(and (exact-integer? expr) - (and (expr . >= . -1073741824) (expr . <= . 1073741823))) - (if (and (expr . >= . 0) - (expr . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) - (out-byte (+ CPT_SMALL_NUMBER_START expr) out) - (begin - (out-byte CPT_INT out) - (out-number expr out)))] - [(null? expr) - (out-byte CPT_NULL out)] - [(eq? expr #t) - (out-byte CPT_TRUE out)] - [(eq? expr #f) - (out-byte CPT_FALSE out)] - [(void? expr) - (out-byte CPT_VOID out)] - [(box? expr) - (out-byte CPT_BOX out) - (out-data (unbox expr) out)] - [(pair? expr) - (local [(define seen? (make-hasheq)) ; XXX Maybe this should be global? - (define (list-length-before-cycle/improper-end l) - (if (hash-has-key? seen? l) - (begin (values 0 #f)) - (begin (hash-set! seen? l #t) - (cond - [(null? l) - (values 0 #t)] - [(pair? l) - (let-values ([(len proper?) - (list-length-before-cycle/improper-end (cdr l))]) - (values (add1 len) proper?))] - [else - (values 0 #f)])))) - (define-values (len proper?) (list-length-before-cycle/improper-end expr)) - (define (print-contents-as-proper) - (for ([e (in-list expr)]) - (out-data e out))) - (define (print-contents-as-improper) - (let loop ([l expr] [i len]) - (cond - [(zero? i) - (out-data l out)] - [else - (out-data (car l) out) - (loop (cdr l) (sub1 i))])))] - (if proper? - (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) - (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) - (print-contents-as-proper)) - (begin (out-byte CPT_LIST out) - (out-number len out) - (print-contents-as-proper) - (out-data null out))) - (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) - ; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR - (begin (out-byte (+ CPT_SMALL_LIST_START len) out) - (print-contents-as-improper)) - (begin (out-byte CPT_LIST out) - (out-number len out) - (print-contents-as-improper)))))] - [(vector? expr) - (out-byte CPT_VECTOR out) - (out-number (vector-length expr) out) - (for ([v (in-vector expr)]) - (out-data v out))] - [(hash? expr) - (out-shared expr out - (lambda () - (out-byte CPT_HASH_TABLE out) - (out-number (cond - [(hash-eqv? expr) 2] - [(hash-eq? expr) 0] - [else 1]) - out) - (out-number (hash-count expr) out) - (for ([(k v) (in-hash expr)]) - (out-data k out) - (out-data v out))))] - [(svector? expr) - (let* ([vec (svector-vec expr)] - [len (vector-length vec)]) - (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) - (out-byte (+ CPT_SMALL_SVECTOR_START len) out) - (begin (out-byte CPT_SVECTOR out) - (out-number len out))) - (for ([n (in-range (sub1 len) -1 -1)]) - (out-number (vector-ref vec n) out)))] - [(module-path-index? expr) - (out-shared expr out - (lambda () - (out-byte CPT_MODULE_INDEX out) - (let-values ([(name base) (module-path-index-split expr)]) - (out-data name out) - (out-data base out))))] - [(module-decl? expr) - (out-marshaled module-type-num - (module-decl-content expr) - out)] - [(stx? expr) - (out-stx expr out)] - [(wrapped? expr) - (out-wrapped expr out)] - [(prefab-struct-key expr) - => (lambda (key) - (define pre-v (struct->vector expr)) - (vector-set! pre-v 0 key) - (out-byte CPT_PREFAB out) - (out-data pre-v out))] - [else - (out-byte CPT_QUOTE out) - (if (quoted? expr) - (out-data (quoted-v expr) out) - (let ([s (open-output-bytes)]) - ;; print `expr' to a string, but print paths - ;; in a special way - (parameterize ([pretty-print-size-hook - (lambda (v mode port) - (and (path? v) - (let ([v (make-relative v)]) - (+ 2 (let ([p (open-output-bytes)]) - (write (path->bytes v) p) - (bytes-length (get-output-bytes p)))))))] - [pretty-print-print-hook - (lambda (v mode port) - (display "#^" port) - (write (path->bytes (make-relative v)) port))]) - (pretty-write expr s)) - (out-byte CPT_ESCAPE out) - (let ([bstr (get-output-bytes s)]) - (out-number (bytes-length bstr) out) - (out-bytes bstr out))))])) - + (define s (->bytes expr)) + (out-byte CPT out) + (when before-length + (out-number before-length out)) + (out-number (bytes-length s) out) + (when len2 (out-number len2 out)) + (out-bytes s out)) (define-struct quoted (v)) @@ -1057,11 +986,5 @@ (define-struct svector (vec)) -(define (make-relative v) - (let ([r (current-write-relative-directory)]) - (if r - (find-relative-path r v) - v))) - ;; ---------------------------------------- diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index b7889fe291..9d57363ec8 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1,9 +1,11 @@ #lang scheme/base -(require mzlib/etc +(require mzlib/etc + racket/function scheme/match scheme/list unstable/struct - compiler/zo-structs) + compiler/zo-structs + racket/dict) (provide zo-parse) (provide (all-from-out compiler/zo-structs)) @@ -30,6 +32,8 @@ ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms +(define debug-symrefs #f) + (define (read-toplevel v) (define SCHEME_TOPLEVEL_CONST #x01) (define SCHEME_TOPLEVEL_READY #x02) @@ -503,157 +507,172 @@ ;; ---------------------------------------- ;; Syntax unmarshaling +(define (make-memo) (make-weak-hash)) +(define (with-memo* mt arg thnk) + (hash-ref! mt arg thnk)) +(define-syntax-rule (with-memo mt arg body ...) + (with-memo* mt arg (λ () body ...))) + (define (decode-mark-map alist) - alist - #;(let loop ([alist alist] - [ht (make-immutable-hasheq empty)]) - (match alist - [(list) ht] - [(list* (? number? key) (? module-path-index? val) alist) - (loop alist (hash-set ht key val))]))) + alist) +(define marks-memo (make-memo)) (define (decode-marks cp ms) - (match ms - [#f #f] - [(list* #f (? number? symref) alist) - (make-certificate:ref - (vector-ref (cport-symtab cp) symref) - (decode-mark-map alist))] - [(list* (? list? nested) alist) - (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))])) + (with-memo marks-memo ms + (match ms + [#f #f] + [(list* #f (? number? symref) alist) + (make-certificate:ref + (symtab-lookup cp symref) + (decode-mark-map alist))] + [(list* (? list? nested) alist) + (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))]))) +(define stx-memo (make-memo)) +; XXX More memo use (define (decode-stx cp v) - (if (integer? v) - (unmarshal-stx-get/decode cp v decode-stx) - (let loop ([v v]) - (let-values ([(cert-marks v encoded-wraps) - (match v - [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] - [`(,datum . ,wraps) (values #f datum wraps)] - [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) - (let* ([wraps (decode-wraps cp encoded-wraps)] - [marks (decode-marks cp cert-marks)] - [add-wrap (lambda (v) (make-wrapped v wraps marks))]) - (cond - [(pair? v) - (if (eq? #t (car v)) - ;; Share decoded wraps with all nested parts. - (let loop ([v (cdr v)]) - (cond - [(pair? v) - (let ploop ([v v]) + (with-memo stx-memo v + (if (integer? v) + (unmarshal-stx-get/decode cp v decode-stx) + (let loop ([v v]) + (let-values ([(cert-marks v encoded-wraps) + (match v + [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] + [`(,datum . ,wraps) (values #f datum wraps)] + [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) + (let* ([wraps (decode-wraps cp encoded-wraps)] + [marks (decode-marks cp cert-marks)] + [wrapped-memo (make-memo)] + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))]) + (cond + [(pair? v) + (if (eq? #t (car v)) + ;; Share decoded wraps with all nested parts. + (let loop ([v (cdr v)]) + (cond + [(pair? v) + (let ploop ([v v]) + (cond + [(null? v) null] + [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] + [else (loop v)]))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)])) + ;; Decode sub-elements that have their own wraps: + (let-values ([(v counter) (if (exact-integer? (car v)) + (values (cdr v) (car v)) + (values v -1))]) + (add-wrap + (let ploop ([v v][counter counter]) (cond [(null? v) null] - [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] - [else (loop v)]))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)])) - ;; Decode sub-elements that have their own wraps: - (let-values ([(v counter) (if (exact-integer? (car v)) - (values (cdr v) (car v)) - (values v -1))]) - (add-wrap - (let ploop ([v v][counter counter]) - (cond - [(null? v) null] - [(or (not (pair? v)) (zero? counter)) (loop v)] - [(pair? v) (cons (loop (car v)) - (ploop (cdr v) (sub1 counter)))])))))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)])))))) + [(or (not (pair? v)) (zero? counter)) (loop v)] + [(pair? v) (cons (loop (car v)) + (ploop (cdr v) (sub1 counter)))])))))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)]))))))) +(define wrape-memo (make-memo)) +(define (decode-wrape cp a) + (define (aloop a) (decode-wrape cp a)) + (with-memo wrape-memo a + ; A wrap-elem is either + (cond + ; A reference + [(integer? a) + (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] + ; A mark (not actually a number as the C says, but a (list ) + [(and (pair? a) (number? (car a))) + (make-wrap-mark (car a))] + + [(vector? a) + (make-lexical-rename (vector-ref a 0) (vector-ref a 1) + (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) + (let loop ([i 2]) + (if (= i top) + null + (cons (cons (vector-ref a i) + (vector-ref a (+ (- top 2) i))) + (loop (+ i 1)))))))] + [(pair? a) + (let-values ([(plus-kern? a) (if (eq? (car a) #t) + (values #t (cdr a)) + (values #f a))]) + (match a + [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) + (let-values ([(unmarshals renames mark-renames) + (if (vector? maybe-unmarshals) + (values null maybe-unmarshals renames) + (values maybe-unmarshals + (car renames) + (cdr renames)))]) + (make-module-rename phase + (if kind 'marked 'normal) + set-id + (map (curry decode-all-from-module cp) unmarshals) + (decode-renames renames) + mark-renames + (and plus-kern? 'plus-kern)))] + [else (error "bad module rename: ~e" a)]))] + [(boolean? a) + (make-top-level-rename a)] + [(symbol? a) + (make-mark-barrier a)] + [(box? a) + (match (unbox a) + [(list (? symbol?) ...) (make-prune (unbox a))] + [`#(,amt ,src ,dest #f) + (make-phase-shift amt + (parse-module-path-index cp src) + (parse-module-path-index cp dest))] + [else (error 'parse "bad phase shift: ~e" a)])] + [else (error 'decode-wraps "bad wrap element: ~e" a)]))) + +(define all-from-module-memo (make-memo)) +(define (decode-all-from-module cp afm) + (define (phase? v) + (or (number? v) (not v))) + (with-memo all-from-module-memo afm + (match afm + [(list* path (? phase? phase) (? phase? src-phase) + (list exn ...) prefix) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn (vector prefix))] + [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn #f)] + [(list* path (? phase? phase) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase #f #f)]))) + +(define wraps-memo (make-memo)) (define (decode-wraps cp w) - ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) - (if (integer? w) - (unmarshal-stx-get/decode cp w decode-wraps) - (map (lambda (a) - (let aloop ([a a]) - ; A wrap-elem is either - (cond - ; A reference - [(integer? a) - (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] - ; A mark (not actually a number as the C says, but a (list ) - [(and (pair? a) (number? (car a))) - (make-wrap-mark (car a))] - - [(vector? a) - (make-lexical-rename (vector-ref a 0) (vector-ref a 1) - (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) - (let loop ([i 2]) - (if (= i top) - null - (cons (cons (vector-ref a i) - (vector-ref a (+ (- top 2) i))) - (loop (+ i 1)))))))] - [(pair? a) - (let-values ([(plus-kern? a) (if (eq? (car a) #t) - (values #t (cdr a)) - (values #f a))]) - (match a - [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) - (let-values ([(unmarshals renames mark-renames) - (if (vector? maybe-unmarshals) - (values null maybe-unmarshals renames) - (values maybe-unmarshals - (car renames) - (cdr renames)))]) - (make-module-rename phase - (if kind 'marked 'normal) - set-id - (map (local [(define (phase? v) - (or (number? v) (not v)))] - (match-lambda - [(list* path (? phase? phase) (? phase? src-phase) - (list exn ...) prefix) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase exn (vector prefix))] - [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase exn #f)] - [(list* path (? phase? phase) (? phase? src-phase)) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase #f #f)])) - unmarshals) - (decode-renames renames) - mark-renames - (and plus-kern? 'plus-kern)))] - [else (error "bad module rename: ~e" a)]))] - [(boolean? a) - (make-top-level-rename a)] - [(symbol? a) - (make-mark-barrier a)] - [(box? a) - (match (unbox a) - [(list (? symbol?) ...) (make-prune (unbox a))] - [`#(,amt ,src ,dest #f) - (make-phase-shift amt - (parse-module-path-index cp src) - (parse-module-path-index cp dest))] - [else (error 'parse "bad phase shift: ~e" a)])] - [else (error 'decode-wraps "bad wrap element: ~e" a)]))) - w))) + (with-memo wraps-memo w + ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) + (if (integer? w) + (unmarshal-stx-get/decode cp w decode-wraps) + (map (curry decode-wrape cp) w)))) (define (in-vector* v n) (make-do-sequence @@ -665,40 +684,48 @@ (λ _ #t) (λ _ #t))))) -(define (decode-renames renames) - (define decode-nominal-path - (match-lambda +(define nominal-path-memo (make-memo)) +(define (decode-nominal-path np) + (with-memo nominal-path-memo np + (match np [(cons nominal-path (cons import-phase nominal-phase)) (make-phased-nominal-path nominal-path import-phase nominal-phase)] [(cons nominal-path import-phase) (make-imported-nominal-path nominal-path import-phase)] [nominal-path - (make-simple-nominal-path nominal-path)])) - - ; XXX Weird test copied from C code. Matthew? - (define (nom_mod_p p) - (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) - - (for/list ([(k v) (in-vector* renames 2)]) - (cons k - (match v - [(list-rest path phase export-name nominal-path nominal-export-name) - (make-phased-module-binding path - phase - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(list-rest path export-name nominal-path nominal-export-name) - (make-exported-nominal-module-binding path - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(cons module-path-index (? nom_mod_p nominal-path)) - (make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))] - [(cons module-path-index export-name) - (make-exported-module-binding module-path-index export-name)] - [module-path-index - (make-simple-module-binding module-path-index)])))) + (make-simple-nominal-path nominal-path)]))) + +; XXX Weird test copied from C code. Matthew? +(define (nom_mod_p p) + (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) + +(define rename-v-memo (make-memo)) +(define (decode-rename-v v) + (with-memo rename-v-memo v + (match v + [(list-rest path phase export-name nominal-path nominal-export-name) + (make-phased-module-binding path + phase + export-name + (decode-nominal-path nominal-path) + nominal-export-name)] + [(list-rest path export-name nominal-path nominal-export-name) + (make-exported-nominal-module-binding path + export-name + (decode-nominal-path nominal-path) + nominal-export-name)] + [(cons module-path-index (? nom_mod_p nominal-path)) + (make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))] + [(cons module-path-index export-name) + (make-exported-module-binding module-path-index export-name)] + [module-path-index + (make-simple-module-binding module-path-index)]))) + +(define renames-memo (make-memo)) +(define (decode-renames renames) + (with-memo renames-memo renames + (for/list ([(k v) (in-vector* renames 2)]) + (cons k (decode-rename-v v))))) (define (parse-module-path-index cp s) s) @@ -734,7 +761,6 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t] - ;; Use a readtable for special path support in escaped: [current-readtable (make-readtable #f @@ -910,10 +936,10 @@ (make-application (read-compact cp) (for/list ([i (in-range c)]) (read-compact cp))))] - [(closure) + [(closure) ; XXX The use of indirect may be an artifact from pre-placeholder days (let* ([l (read-compact-number cp)] [ind (make-indirect #f)]) - (placeholder-set! (vector-ref (cport-symtab cp) l) ind) + (symtab-write! cp l ind) (let* ([v (read-compact cp)] [cl (make-closure v (gensym (let ([s (lam-name v)]) @@ -941,15 +967,22 @@ (if decoded? v2 (let ([dv2 (decode-stx cp v2)]) - (placeholder-set! (vector-ref (cport-symtab cp) pos) dv2) + (symtab-write! cp pos dv2) (vector-set! (cport-decoded cp) pos #t) dv2))) +(define (symtab-write! cp i v) + (placeholder-set! (vector-ref (cport-symtab cp) i) v)) + +(define (symtab-lookup cp i) + (when (mark-parameter-first read-sym-mark) + (dict-update! debug-symrefs (mark-parameter-first read-sym-mark) (λ (last) (cons i last)) empty)) + (vector-ref (cport-symtab cp) i)) + (require unstable/markparam) (define read-sym-mark (mark-parameter)) (define (read-sym cp i) - (define symtab (cport-symtab cp)) - (define ph (vector-ref symtab i)) + (define ph (symtab-lookup cp i)) ; We are reading this already, so return the placeholder (if (memq i (mark-parameter-all read-sym-mark)) ph @@ -1003,11 +1036,17 @@ (define symtab (build-vector symtabsize (λ (i) (make-placeholder nr)))) + (set! debug-symrefs (make-vector symtabsize empty)) + (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + (for ([i (in-naturals)] + [v (in-vector debug-symrefs)]) + (printf "~a: ~a~n" i v)) + #;(for ([i (in-naturals)] [v (in-vector (cport-symtab cp))]) (printf "~a: ~s~n~n" i (placeholder-get v))) From ae4b7709399eae6529fba0e213dc3719f18b0532 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 20 Aug 2010 13:47:03 -0600 Subject: [PATCH 171/466] zo-marshal fixes and read.c fix for hash tables in symbol table original commit: 9599304ca90d1a76a80e5edcf13f13e9bc83ac53 --- collects/compiler/zo-marshal.rkt | 17 +++++++++++++---- collects/compiler/zo-parse.rkt | 4 ++-- collects/tests/compiler/zo-exs.rkt | 16 +++++++++++++--- 3 files changed, 28 insertions(+), 9 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index fa3be595e9..42d143df7d 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -8,7 +8,9 @@ racket/local racket/list racket/dict - racket/function) + racket/function + racket/pretty + racket/path) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -305,8 +307,8 @@ (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) encoded-bindings) -(define encode-all-from-module - (match-lambda +(define (encode-all-from-module afm) + (match afm [(struct all-from-module (path phase src-phase #f #f)) (list* path phase src-phase)] [(struct all-from-module (path phase src-phase exns #f)) @@ -814,7 +816,7 @@ (lambda (v mode port) (display "#^" port) (write (path->bytes (make-relative v)) port))]) - (pretty-write expr s)) + (pretty-write v s)) (out-byte CPT_ESCAPE out) (let ([bstr (get-output-bytes s)]) (out-number (bytes-length bstr) out) @@ -986,5 +988,12 @@ (define-struct svector (vec)) +(define (make-relative v) + (let ([r (current-write-relative-directory)]) + (if r + (find-relative-path r v) + v))) + + ;; ---------------------------------------- diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 9d57363ec8..3b1b820733 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1043,10 +1043,10 @@ (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) - (for ([i (in-naturals)] + #;(for ([i (in-naturals)] [v (in-vector debug-symrefs)]) (printf "~a: ~a~n" i v)) - + #;(printf "SYMBOL TABLE:~n~n") #;(for ([i (in-naturals)] [v (in-vector (cport-symtab cp))]) (printf "~a: ~s~n~n" i (placeholder-get v))) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 8fd5d3ee47..a5bd61d5f0 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -9,23 +9,33 @@ (define (roundtrip ct) (define bs (zo-marshal ct)) + (with-output-to-file "test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) (test #:failure-prefix (format "~S" ct) (test bs (zo-parse (open-input-bytes bs)) => ct (read-compiled-bytes bs)))) +(define mpi (module-path-index-join #f #f)) + (test - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) - (local [(define (hash-test make-hash-placeholder) + (roundtrip + (compilation-top + 0 + (prefix 0 empty empty) + (cons #hasheq() + #hasheq()))) + + #;(local [(define (hash-test make-hash-placeholder) (roundtrip (compilation-top 0 (prefix 0 empty empty) From 4379002ddce7f0e9aff37653975432671a0344b6 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 23 Aug 2010 18:09:54 -0600 Subject: [PATCH 172/466] traverse while writing rather than a separate step original commit: 88dcab6b5abf562644267d3c3dc8e2d4bc5010e2 --- collects/compiler/zo-marshal.rkt | 224 +++++++++++++------------------ 1 file changed, 95 insertions(+), 129 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 42d143df7d..58aa361ca5 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -21,136 +21,102 @@ (zo-marshal-to top bs) (get-output-bytes bs)) -(define (zo-marshal-to top outp) - (match top - [(struct compilation-top (max-let-depth prefix form)) - (define shared (make-hash)) - (define wrapped (make-hash)) - (define (shared-obj-pos v) - (hash-ref shared v #f)) - (define (share! v) - (hash-set! shared v (add1 (hash-count shared)))) - (define ct - (list* max-let-depth prefix (protect-quote form))) - - ; Compute what objects are in ct multiple times (by equal?) - (local [(define encountered (make-hash)) - (define (encountered? v) - (hash-ref encountered v #f)) - (define (encounter! v) - (hash-set! encountered v #t)) - (define (visit! v) - (cond - [(not (shareable? v)) - #t] - [(shared-obj-pos v) - #f] - [(encountered? v) - (share! v) - #f] - [else - (encounter! v) - ; All closures MUST be in the symbol table - (when (closure? v) - (share! v)) - #t]))] - (traverse wrapped visit! ct)) - - ; Hash tables aren't sorted, so we need to order them - (define in-order-shareds - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car)) - - (define (write-all outp) - ; As we are writing the symbol table entry for v, - ; the writing code will attempt to see if v is shared and - ; insert a symtable reference, which would be wrong. - ; So, the first time it is encountered while writing, - ; we should pretend it ISN'T shared, so it is actually written. - ; However, subsequent times (or for other shared values) - ; we defer to the normal 'shared-obj-pos' - (define (shared-obj-pos/modulo-v v) - (define skip? #t) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (shared-obj-pos v2)))) - ; Write the symbol table, computing offsets as we go - (define offsets - (for/list ([k*v (in-list in-order-shareds)]) - (define v (cdr k*v)) - (begin0 - (file-position outp) - (out-anything v (make-out outp (shared-obj-pos/modulo-v v) wrapped))))) - ; Compute where we ended - (define post-shared (file-position outp)) - ; Write the entire ctop - (out-anything ct - (make-out outp shared-obj-pos wrapped)) - (values offsets post-shared (file-position outp))) - - ; Compute where the symbol table ends - (define counting-p (open-output-nowhere)) - (define-values (offsets post-shared all-forms-length) - (write-all counting-p)) - - ; Write the compiled form header - (write-bytes #"#~" outp) - - ; Write the version (notice that it isn't the same as out-string) - (define version-bs (string->bytes/latin-1 (version))) - (write-bytes (bytes (bytes-length version-bs)) outp) - (write-bytes version-bs outp) - - ; Write the symbol table information (size, offsets) - (define symtabsize (add1 (hash-count shared))) - (write-bytes (int->bytes symtabsize) outp) - (define all-short? (post-shared . < . #xFFFF)) - (write-bytes (bytes (if all-short? 1 0)) outp) - (for ([o (in-list offsets)]) - (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) - - ; Post-shared is where the ctop actually starts - (write-bytes (int->bytes post-shared) outp) - ; This is where the file should end - (write-bytes (int->bytes all-forms-length) outp) - ; Write the symbol table then the ctop - (write-all outp) - (void)])) +; function -> vector +; calculates what values show up in the compilation top more than once +; closures are always included even if they only show up once +(define (create-symbol-table out-compilation-top) + (define encountered (make-hash)) + (define shared (make-hash)) + (define (encountered? v) + (hash-ref encountered v #f)) + (define (encounter! v) + (hash-set! encountered v #t)) + (define (shared-obj-pos v) + (hash-ref shared v #f)) + (define (share! v) + (hash-set! shared v (add1 (hash-count-shared)))) + + (out-compilation-top + (λ (v) + (if (or (closure? v) + (and (encountered? v) + (shareable? v))) + (share! v) + (encounter! v)) + #f) + (open-output-nowhere)) + + (define symbol-table (make-vector (hash-count shared))) + (hash-map shared (λ (k v) (vector-set! symbol-table v k))) + (values symbol-table shared-obj-pos)) -(define (traverse wrapped-ht visit! expr) - (when (visit! expr) - (match expr - [(? wrapped? w) - (define encoded-w - (hash-ref! wrapped-ht w (lambda () (encode-wrapped w)))) - (traverse wrapped-ht visit! encoded-w)] - [(? prefab-struct-key) - (map (curry traverse wrapped-ht visit!) (struct->list expr))] - [(cons l r) - (traverse wrapped-ht visit! l) - (traverse wrapped-ht visit! r)] - [(? vector?) - (for ([v (in-vector expr)]) - (traverse wrapped-ht visit! v))] - [(? hash?) - (for ([(k v) (in-hash expr)]) - (traverse wrapped-ht visit! k) - (traverse wrapped-ht visit! v))] - [(? module-path-index?) - (define-values (name base) (module-path-index-split expr)) - (traverse wrapped-ht visit! name) - (traverse wrapped-ht visit! base)] - [(box v) - (traverse wrapped-ht visit! v)] - [(protected-symref v) - (traverse wrapped-ht visit! v)] - [(quoted v) - (traverse wrapped-ht visit! v)] - [else (void)]))) +(define (zo-marshal-to top outp) + + ; XXX: wraps were encoded in traverse, now needs to be handled when writing + (define wrapped (make-hash)) + + ; function output-port -> number + ; writes top to outp using shared-obj-pos to determine symref + ; returns the file position at the end of the compilation top + (define (out-compilation-top shared-obj-pos outp) + (define ct + (match top + [(compilation-top max-let-depth prefix form) + (list* max-let-depth prefix (protect-quote form))])) + (out-anything ct (make-out outp shared-obj-pos wrapped)) + (file-position outp)) + + (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) + + ; vector output-port -> (listof number) number + ; writes symbol-table to outp + ; returns the file positions of each value in the symbol table and the end of the symbol table + (define (out-symbol-table symbol-table outp) + (define (shared-obj-pos/modulo-v v) + (define skip? #t) + (λ (v2) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (shared-obj-pos v2)))) + (values + (for/list ([v (in-vector symbol-table)]) + (begin0 + (file-position outp) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) wrapped)))) + (file-position outp))) + + ; Calculate file positions + (define counting-port (open-output-nowhere)) + (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) + (define all-forms-length (out-compilation-top shared-obj-pos counting-port)) + + ; Write the compiled form header + (write-bytes #"#~" outp) + + ; Write the version (notice that it isn't the same as out-string) + (define version-bs (string->bytes/latin-1 (version))) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + + ; Write the symbol table information (size, offsets) + (define symtabsize (add1 (hash-count shared))) + (write-bytes (int->bytes symtabsize) outp) + (define all-short? (post-shared . < . #xFFFF)) + (write-bytes (bytes (if all-short? 1 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) + + ; Post-shared is where the ctop actually starts + (write-bytes (int->bytes post-shared) outp) + ; This is where the file should end + (write-bytes (int->bytes all-forms-length) outp) + + ; Actually write the zo + (out-symbol-table symbol-table outp) + (out-compilation-top shared-obj-pos outp) + (void)) ;; ---------------------------------------- From b63f532735a8cf4947ddd46b89562ea5eb1c550f Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 24 Aug 2010 14:42:19 -0600 Subject: [PATCH 173/466] encoding wraps and fixes for zo-marshal sharing original commit: 54f2d34a2e332c79e3f0cce89fa70bb46708fad6 --- collects/compiler/zo-marshal.rkt | 44 ++++++++++++++++-------------- collects/compiler/zo-parse.rkt | 2 +- collects/tests/compiler/zo-exs.rkt | 34 ++++++++++++++++++++++- 3 files changed, 57 insertions(+), 23 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 58aa361ca5..872afea1b1 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -10,18 +10,21 @@ racket/dict racket/function racket/pretty - racket/path) + racket/path + racket/set) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] [zo-marshal-to (compilation-top? output-port? . -> . void?)]) +(struct not-ready ()) + (define (zo-marshal top) (define bs (open-output-bytes)) (zo-marshal-to top bs) (get-output-bytes bs)) -; function -> vector +; ((obj -> (or pos #f)) output-port -> number) -> vector ; calculates what values show up in the compilation top more than once ; closures are always included even if they only show up once (define (create-symbol-table out-compilation-top) @@ -30,24 +33,26 @@ (define (encountered? v) (hash-ref encountered v #f)) (define (encounter! v) - (hash-set! encountered v #t)) + (hash-set! encountered v #t) + #f) (define (shared-obj-pos v) (hash-ref shared v #f)) (define (share! v) - (hash-set! shared v (add1 (hash-count-shared)))) + (or (hash-ref shared v #f) + (let ([pos (add1 (hash-count shared))]) + (hash-set! shared v pos) + pos))) (out-compilation-top (λ (v) (if (or (closure? v) - (and (encountered? v) - (shareable? v))) + (encountered? v)) (share! v) - (encounter! v)) - #f) + (encounter! v))) (open-output-nowhere)) - (define symbol-table (make-vector (hash-count shared))) - (hash-map shared (λ (k v) (vector-set! symbol-table v k))) + (define symbol-table (make-vector (hash-count shared) (not-ready))) + (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) (values symbol-table shared-obj-pos)) (define (zo-marshal-to top outp) @@ -55,7 +60,7 @@ ; XXX: wraps were encoded in traverse, now needs to be handled when writing (define wrapped (make-hash)) - ; function output-port -> number + ; (obj -> (or pos #f)) output-port -> number ; writes top to outp using shared-obj-pos to determine symref ; returns the file position at the end of the compilation top (define (out-compilation-top shared-obj-pos outp) @@ -65,9 +70,8 @@ (list* max-let-depth prefix (protect-quote form))])) (out-anything ct (make-out outp shared-obj-pos wrapped)) (file-position outp)) - (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) - + ; vector output-port -> (listof number) number ; writes symbol-table to outp ; returns the file positions of each value in the symbol table and the end of the symbol table @@ -91,7 +95,6 @@ (define counting-port (open-output-nowhere)) (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) (define all-forms-length (out-compilation-top shared-obj-pos counting-port)) - ; Write the compiled form header (write-bytes #"#~" outp) @@ -101,13 +104,12 @@ (write-bytes version-bs outp) ; Write the symbol table information (size, offsets) - (define symtabsize (add1 (hash-count shared))) + (define symtabsize (add1 (vector-length symbol-table))) (write-bytes (int->bytes symtabsize) outp) (define all-short? (post-shared . < . #xFFFF)) (write-bytes (bytes (if all-short? 1 0)) outp) (for ([o (in-list offsets)]) (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) - ; Post-shared is where the ctop actually starts (write-bytes (int->bytes post-shared) outp) ; This is where the file should end @@ -686,14 +688,14 @@ (out-anything (unbox v) out)] [(? pair?) (define (list-length-before-cycle/improper-end l) - (let loop ([len 1] [l (cdr l)]) + (let loop ([len 1] [l (cdr l)] [seen (set)]) (cond - [((out-shared-index out) l) + [(set-member? seen l) (values len #f)] [(null? l) (values len #t)] [(pair? l) - (loop (add1 len) (cdr l))] + (loop (add1 len) (cdr l) (set-add seen l))] [else (values len #f)]))) (define-values (len proper?) (list-length-before-cycle/improper-end v)) @@ -884,8 +886,8 @@ (define (lookup-encoded-wrapped w out) (hash-ref (out-encoded-wraps out) w - (lambda () - (error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w)))) + (λ () + (encode-wrapped w)))) (define (out-lam expr out) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 3b1b820733..5e195c90a7 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1046,7 +1046,7 @@ #;(for ([i (in-naturals)] [v (in-vector debug-symrefs)]) (printf "~a: ~a~n" i v)) - #;(printf "SYMBOL TABLE:~n~n") + #;(printf "SYMBOL TABLE(~a):~n~n" symtabsize) #;(for ([i (in-naturals)] [v (in-vector (cport-symtab cp))]) (printf "~a: ~s~n~n" i (placeholder-get v))) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index a5bd61d5f0..c46e7fd7e6 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -18,6 +18,38 @@ (define mpi (module-path-index-join #f #f)) (test + (roundtrip + (compilation-top + 0 + (prefix 0 (list #f) (list)) + (mod + 'simple + 'simple + (module-path-index-join #f #f) + (prefix + 0 + (list (module-variable + (module-path-index-join + "modbeg.rkt" + (module-path-index-join + "pre-base.rkt" + (module-path-index-join + "namespace.rkt" + (module-path-index-join "private/base.rkt" (module-path-index-join 'racket/base #f))))) 'print-values 0 0)) + (list)) + (list) + (list (list 0 (module-path-index-join 'racket/base #f)) (list 1) (list -1) (list #f)) + (list (apply-values + (toplevel 0 0 #f #t) + (application + (primval 231) + (list 1 'a)))) + (list) + (list (list) (list) (list)) + 2 + (toplevel 0 0 #f #f) + #(racket/language-info get-info #f) + #t))) #;(roundtrip (compilation-top 0 (prefix 0 empty empty) @@ -28,7 +60,7 @@ (prefix 0 empty empty) (list (current-directory)))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) From b816da148dd939bb11523edd102a144d13dcb51c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 24 Aug 2010 17:12:32 -0600 Subject: [PATCH 174/466] quoting parameter and not prefab structs original commit: 893294674a77ed6d6f84df6d54017c1bc7bd34ce --- collects/compiler/zo-marshal.rkt | 9 +++++++-- collects/compiler/zo-structs.rkt | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 872afea1b1..a34d4c6445 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -425,13 +425,17 @@ (define (or-pred? v . ps) (ormap (lambda (?) (? v)) ps)) + +(define quoting? (make-parameter #f)) + (define (shareable? v) - (not (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?))) + (not (or quoting? (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) (define (maybe-same-as-fixnum? v) (and (exact-integer? v) (and (v . >= . -1073741824) (v . <= . 1073741823)))) + (define (out-anything v out) (out-shared v out @@ -771,7 +775,8 @@ [else (out-byte CPT_QUOTE out) (if (quoted? v) - (out-anything (quoted-v v) out) + (parameterize ([quoting? #t]) + (out-anything (quoted-v v) out)) (let ([s (open-output-bytes)]) (parameterize ([pretty-print-size-hook (lambda (v mode port) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 509a2dc7d5..cbb987a5fa 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -22,7 +22,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin - (define-struct id+par (field-id ...) #:prefab) + (define-struct id+par (field-id ...)) #;(provide (struct-out id)) (provide/contract [struct id ([field-id field-contract] ...)]))) From 46f22d28829a8131e4419be62d1d1b140f3d1bf7 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 24 Aug 2010 17:28:00 -0600 Subject: [PATCH 175/466] handling closures while writing symbol table original commit: c2fee2a2f078bcff4256d1ccb0ed8f99c9447cf2 --- collects/compiler/zo-marshal.rkt | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index a34d4c6445..444afc38db 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -38,7 +38,7 @@ (define (shared-obj-pos v) (hash-ref shared v #f)) (define (share! v) - (or (hash-ref shared v #f) + (or (shared-obj-pos v) (let ([pos (add1 (hash-count shared))]) (hash-set! shared v pos) pos))) @@ -70,8 +70,8 @@ (list* max-let-depth prefix (protect-quote form))])) (out-anything ct (make-out outp shared-obj-pos wrapped)) (file-position outp)) + (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) - ; vector output-port -> (listof number) number ; writes symbol-table to outp ; returns the file positions of each value in the symbol table and the end of the symbol table @@ -79,7 +79,7 @@ (define (shared-obj-pos/modulo-v v) (define skip? #t) (λ (v2) - (if (and skip? (eq? v v2)) + (if (and skip? (eq? v v2) (not (closure? v2))) (begin (set! skip? #f) #f) @@ -102,6 +102,7 @@ (define version-bs (string->bytes/latin-1 (version))) (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) + ; Write the symbol table information (size, offsets) (define symtabsize (add1 (vector-length symbol-table))) From a5f557b90e214eeb435b20230f9cee8c24f6c59c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 25 Aug 2010 17:25:10 -0600 Subject: [PATCH 176/466] zo-marshal fixes and switching back to prefabs original commit: ecc9ceb842fc928615d5c59273feee799b285d4b --- collects/compiler/zo-marshal.rkt | 100 ++++++++++++++++------------- collects/compiler/zo-structs.rkt | 10 ++- collects/tests/compiler/zo-exs.rkt | 23 +++++++ 3 files changed, 87 insertions(+), 46 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 444afc38db..67e44567d4 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -10,8 +10,7 @@ racket/dict racket/function racket/pretty - racket/path - racket/set) + racket/path) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -24,36 +23,8 @@ (zo-marshal-to top bs) (get-output-bytes bs)) -; ((obj -> (or pos #f)) output-port -> number) -> vector -; calculates what values show up in the compilation top more than once -; closures are always included even if they only show up once -(define (create-symbol-table out-compilation-top) - (define encountered (make-hash)) - (define shared (make-hash)) - (define (encountered? v) - (hash-ref encountered v #f)) - (define (encounter! v) - (hash-set! encountered v #t) - #f) - (define (shared-obj-pos v) - (hash-ref shared v #f)) - (define (share! v) - (or (shared-obj-pos v) - (let ([pos (add1 (hash-count shared))]) - (hash-set! shared v pos) - pos))) - - (out-compilation-top - (λ (v) - (if (or (closure? v) - (encountered? v)) - (share! v) - (encounter! v))) - (open-output-nowhere)) - - (define symbol-table (make-vector (hash-count shared) (not-ready))) - (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) - (values symbol-table shared-obj-pos)) +(define (got-here n) + (void) #;(printf "got here: ~a~n" n)) (define (zo-marshal-to top outp) @@ -71,14 +42,51 @@ (out-anything ct (make-out outp shared-obj-pos wrapped)) (file-position outp)) - (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) + ; -> vector + ; calculates what values show up in the compilation top more than once + ; closures are always included even if they only show up once + (define (create-symbol-table) + (define encountered (make-hash)) + (define shared (make-hash)) + (define (encountered? v) + (hash-ref encountered v #f)) + (define (encounter! v) + (hash-set! encountered v #t) + #f) + (define (shared-obj-pos v #:share [share? #t]) + (hash-ref shared v #f)) + (define (share! v) + (or (shared-obj-pos v) + (let ([pos (add1 (hash-count shared))]) + (hash-set! shared v pos) + pos))) + + (out-compilation-top + (λ (v #:share [share? #t]) + (and share? + (if (or (closure? v) + (encountered? v)) + (share! v) + (encounter! v)))) + (open-output-nowhere)) + + (define symbol-table (make-vector (hash-count shared) (not-ready))) + (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) + (values symbol-table shared-obj-pos)) + + (got-here 1) + (define-values (symbol-table shared-obj-pos) (create-symbol-table)) + (got-here 2) + #;(for ([v (in-vector symbol-table)]) + (printf "v = ~a~n" v)) + ; vector output-port -> (listof number) number ; writes symbol-table to outp ; returns the file positions of each value in the symbol table and the end of the symbol table (define (out-symbol-table symbol-table outp) (define (shared-obj-pos/modulo-v v) (define skip? #t) - (λ (v2) + (λ (v2 #:share [share? #t]) (if (and skip? (eq? v v2) (not (closure? v2))) (begin (set! skip? #f) @@ -94,7 +102,9 @@ ; Calculate file positions (define counting-port (open-output-nowhere)) (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) + (got-here 3) (define all-forms-length (out-compilation-top shared-obj-pos counting-port)) + (got-here 4) ; Write the compiled form header (write-bytes #"#~" outp) @@ -115,10 +125,12 @@ (write-bytes (int->bytes post-shared) outp) ; This is where the file should end (write-bytes (int->bytes all-forms-length) outp) - + (got-here 5) ; Actually write the zo (out-symbol-table symbol-table outp) + (got-here 6) (out-compilation-top shared-obj-pos outp) + (got-here 7) (void)) ;; ---------------------------------------- @@ -430,7 +442,7 @@ (define quoting? (make-parameter #f)) (define (shareable? v) - (not (or quoting? (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) + (not (or (quoting?) (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) (define (maybe-same-as-fixnum? v) (and (exact-integer? v) @@ -631,7 +643,9 @@ (begin (out-byte CPT_APPLICATION out) (out-number len out))) - (for-each (lambda (e) (out-anything (protect-quote e) out)) + (for-each (lambda (e) + #;(printf "here: ~a~n" e) + (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) (out-syntax APPVALS_EXPD @@ -693,14 +707,14 @@ (out-anything (unbox v) out)] [(? pair?) (define (list-length-before-cycle/improper-end l) - (let loop ([len 1] [l (cdr l)] [seen (set)]) + (let loop ([len 1] [l (cdr l)]) (cond - [(set-member? seen l) + [((out-shared-index out) l #:share #f) (values len #f)] [(null? l) (values len #t)] [(pair? l) - (loop (add1 len) (cdr l) (set-add seen l))] + (loop (add1 len) (cdr l))] [else (values len #f)]))) (define-values (len proper?) (list-length-before-cycle/improper-end v)) @@ -740,7 +754,7 @@ (out-number (cond [(hash-eqv? v) 2] [(hash-eq? v) 0] - [else 1]) + [(hash-equal? v) 1]) out) (out-number (hash-count v) out) (for ([(k v) (in-hash v)]) @@ -891,7 +905,7 @@ (define (lookup-encoded-wrapped w out) - (hash-ref (out-encoded-wraps out) w + (hash-ref! (out-encoded-wraps out) w (λ () (encode-wrapped w)))) @@ -955,7 +969,7 @@ (define-struct quoted (v)) (define (protect-quote v) - (if (or (pair? v) (vector? v) (prefab-struct-key v) (box? v) (hash? v) (svector? v)) + (if (or (pair? v) (vector? v) (and (not zo?) (prefab-struct-key v)) (box? v) (hash? v) (svector? v)) (make-quoted v) v)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index cbb987a5fa..acb2476831 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -22,17 +22,20 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin - (define-struct id+par (field-id ...)) + (define-struct id+par (field-id ...) #:prefab) #;(provide (struct-out id)) (provide/contract [struct id ([field-id field-contract] ...)]))) +(define-struct zo () #:prefab) +(provide zo?) + (define-syntax define-form-struct (syntax-rules () [(_ (id sup) . rest) (define-form-struct* id (id sup) . rest)] [(_ id . rest) - (define-form-struct* id id . rest)])) + (define-form-struct* id (id zo) . rest)])) ;; In toplevels of resove prefix: (define-form-struct global-bucket ([name symbol?])) ; top-level binding @@ -77,7 +80,8 @@ (define-form-struct (expr form) ()) ;; A static closure can refer directly to itself, creating a cycle -(define-struct indirect ([v #:mutable]) #:prefab) +; XXX: this might not be needed anymore with the current sharing model +(define-struct (indirect zo) ([v #:mutable]) #:prefab) (define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index c46e7fd7e6..872d025b5a 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -17,8 +17,31 @@ (define mpi (module-path-index-join #f #f)) + (test + #;(roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list 1 (list 2 3) (list 2 3) 4 5))) (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (let* ([ph (make-placeholder #f)] + [x (closure + (lam 'name + empty + 0 + empty + #f + #() + empty + 0 + ph) + (gensym))]) + (placeholder-set! ph x) + (make-reader-graph x)))) + + #;(roundtrip (compilation-top 0 (prefix 0 (list #f) (list)) From b8fe95cd26c4320df22cb6b02941208ee7ecdb5a Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 27 Aug 2010 15:36:45 -0600 Subject: [PATCH 177/466] fixing closure problem original commit: 2dfaab00f4d3a02315c9048456d3c9993be6f4c1 --- collects/compiler/zo-marshal.rkt | 2 +- collects/compiler/zo-parse.rkt | 14 +-- collects/tests/compiler/zo-exs.rkt | 142 ++++++++++++++--------------- 3 files changed, 80 insertions(+), 78 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 67e44567d4..83e629ee4e 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -87,7 +87,7 @@ (define (shared-obj-pos/modulo-v v) (define skip? #t) (λ (v2 #:share [share? #t]) - (if (and skip? (eq? v v2) (not (closure? v2))) + (if (and skip? (eq? v v2) #;(not (closure? v2))) (begin (set! skip? #f) #f) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 5e195c90a7..28d0bd4ac5 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -941,12 +941,14 @@ [ind (make-indirect #f)]) (symtab-write! cp l ind) (let* ([v (read-compact cp)] - [cl (make-closure v (gensym - (let ([s (lam-name v)]) - (cond - [(symbol? s) s] - [(vector? s) (vector-ref s 0)] - [else 'closure]))))]) + [cl (make-closure v + ; XXX Why call gensym here? + (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure]))))]) (set-indirect-v! ind cl) ind))] [(svector) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 872d025b5a..79ab23f1e7 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -20,86 +20,86 @@ (test #;(roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (list 1 (list 2 3) (list 2 3) 4 5))) + (compilation-top 0 + (prefix 0 empty empty) + (list 1 (list 2 3) (list 2 3) 4 5))) (roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] - [x (closure - (lam 'name - empty - 0 - empty - #f - #() - empty - 0 - ph) - (gensym))]) + [x (indirect (closure + (lam 'name + empty + 0 + empty + #f + #() + empty + 0 + ph) + 'name))]) (placeholder-set! ph x) (make-reader-graph x)))) - - #;(roundtrip - (compilation-top - 0 - (prefix 0 (list #f) (list)) - (mod - 'simple - 'simple - (module-path-index-join #f #f) - (prefix - 0 - (list (module-variable - (module-path-index-join - "modbeg.rkt" - (module-path-index-join - "pre-base.rkt" - (module-path-index-join - "namespace.rkt" - (module-path-index-join "private/base.rkt" (module-path-index-join 'racket/base #f))))) 'print-values 0 0)) - (list)) - (list) - (list (list 0 (module-path-index-join 'racket/base #f)) (list 1) (list -1) (list #f)) - (list (apply-values - (toplevel 0 0 #f #t) - (application - (primval 231) - (list 1 'a)))) - (list) - (list (list) (list) (list)) - 2 - (toplevel 0 0 #f #f) - #(racket/language-info get-info #f) - #t))) - #;(roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (current-directory))) - - #;(roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (list (current-directory)))) #;(roundtrip - (compilation-top - 0 - (prefix 0 empty empty) - (cons #hasheq() - #hasheq()))) + (compilation-top + 0 + (prefix 0 (list #f) (list)) + (mod + 'simple + 'simple + (module-path-index-join #f #f) + (prefix + 0 + (list (module-variable + (module-path-index-join + "modbeg.rkt" + (module-path-index-join + "pre-base.rkt" + (module-path-index-join + "namespace.rkt" + (module-path-index-join "private/base.rkt" (module-path-index-join 'racket/base #f))))) 'print-values 0 0)) + (list)) + (list) + (list (list 0 (module-path-index-join 'racket/base #f)) (list 1) (list -1) (list #f)) + (list (apply-values + (toplevel 0 0 #f #t) + (application + (primval 231) + (list 1 'a)))) + (list) + (list (list) (list) (list)) + 2 + (toplevel 0 0 #f #f) + #(racket/language-info get-info #f) + #t))) + #;(roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (current-directory))) + + #;(roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list (current-directory)))) + + #;(roundtrip + (compilation-top + 0 + (prefix 0 empty empty) + (cons #hasheq() + #hasheq()))) #;(local [(define (hash-test make-hash-placeholder) - (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (local [(define ht-ph (make-placeholder #f)) - (define ht (make-hash-placeholder (list (cons 'g ht-ph))))] - (placeholder-set! ht-ph ht) - (make-reader-graph ht)))))] - (hash-test make-hash-placeholder) - (hash-test make-hasheq-placeholder) - (hash-test make-hasheqv-placeholder))) + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (local [(define ht-ph (make-placeholder #f)) + (define ht (make-hash-placeholder (list (cons 'g ht-ph))))] + (placeholder-set! ht-ph ht) + (make-reader-graph ht)))))] + (hash-test make-hash-placeholder) + (hash-test make-hasheq-placeholder) + (hash-test make-hasheqv-placeholder))) From 070d86473db1209fa51cb399821ceb22fa0577b5 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 2 Sep 2010 12:30:38 -0600 Subject: [PATCH 178/466] traversing inside closures and using a seen set for lists original commit: 32a9e60abeac894f6587213787bccb8bd72bd0e2 --- collects/compiler/zo-marshal.rkt | 163 +++++++++++++++++++---------- collects/compiler/zo-parse.rkt | 4 + collects/tests/compiler/zo-exs.rkt | 3 +- 3 files changed, 112 insertions(+), 58 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 83e629ee4e..74eabb5f48 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -10,7 +10,8 @@ racket/dict racket/function racket/pretty - racket/path) + racket/path + racket/set) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -24,7 +25,8 @@ (get-output-bytes bs)) (define (got-here n) - (void) #;(printf "got here: ~a~n" n)) + (void) + #;(printf "got here: ~a~n" n)) (define (zo-marshal-to top outp) @@ -34,12 +36,12 @@ ; (obj -> (or pos #f)) output-port -> number ; writes top to outp using shared-obj-pos to determine symref ; returns the file position at the end of the compilation top - (define (out-compilation-top shared-obj-pos outp) + (define (out-compilation-top shared-obj-pos shared-obj-unsee outp) (define ct (match top [(compilation-top max-let-depth prefix form) (list* max-let-depth prefix (protect-quote form))])) - (out-anything ct (make-out outp shared-obj-pos wrapped)) + (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee wrapped)) (file-position outp)) ; -> vector @@ -49,25 +51,46 @@ (define encountered (make-hash)) (define shared (make-hash)) (define (encountered? v) - (hash-ref encountered v #f)) + ((hash-ref encountered v 0) . > . 0)) (define (encounter! v) - (hash-set! encountered v #t) + (hash-update! encountered v add1 0) #f) - (define (shared-obj-pos v #:share [share? #t]) - (hash-ref shared v #f)) - (define (share! v) + (define (unencounter! v) + (define how-many-encounters (hash-ref encountered v)) + (when (= how-many-encounters 1) + (hash-set! encountered v 0))) + (define (shared-obj-pos v #:error? [error? #f]) + (define pos + (hash-ref shared v + (if error? + (λ () (error 'symref "~e not in symbol table" v)) + #f))) + #;(when (closure? v) + (printf "Looking up ~a, got ~a\n" v pos)) + pos) + (define (share! v) ; XXX this doesn't always set something, probably should be refactored (or (shared-obj-pos v) (let ([pos (add1 (hash-count shared))]) (hash-set! shared v pos) pos))) (out-compilation-top - (λ (v #:share [share? #t]) - (and share? - (if (or (closure? v) - (encountered? v)) - (share! v) - (encounter! v)))) + (λ (v #:error? [error? #f]) + (cond + [(closure? v) + (let ([pos (share! v)]) + (if (encountered? v) + pos + (encounter! v)))] + #;[error? ; If we would error if this were not present, then we must share it + (encounter! v) + (share! v)] + [(encountered? v) + (share! v)] + [else + (encounter! v)])) + (λ (v) + (unencounter! v)) (open-output-nowhere)) (define symbol-table (make-vector (hash-count shared) (not-ready))) @@ -75,7 +98,8 @@ (values symbol-table shared-obj-pos)) (got-here 1) - (define-values (symbol-table shared-obj-pos) (create-symbol-table)) + (define-values (symbol-table shared-obj-pos) + (create-symbol-table)) (got-here 2) #;(for ([v (in-vector symbol-table)]) (printf "v = ~a~n" v)) @@ -86,24 +110,27 @@ (define (out-symbol-table symbol-table outp) (define (shared-obj-pos/modulo-v v) (define skip? #t) - (λ (v2 #:share [share? #t]) - (if (and skip? (eq? v v2) #;(not (closure? v2))) + (λ (v2 #:error? [error? #f]) + (if (and skip? (eq? v v2)) (begin (set! skip? #f) #f) - (shared-obj-pos v2)))) + (shared-obj-pos v2 + #:error? error?)))) (values - (for/list ([v (in-vector symbol-table)]) + (for/list ([v (in-vector symbol-table)] + [i (in-naturals)]) (begin0 (file-position outp) - (out-anything v (make-out outp (shared-obj-pos/modulo-v v) wrapped)))) + #;(printf "Out ~a -->" i) #;(pretty-print v) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void wrapped)))) (file-position outp))) ; Calculate file positions (define counting-port (open-output-nowhere)) (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) (got-here 3) - (define all-forms-length (out-compilation-top shared-obj-pos counting-port)) + (define all-forms-length (out-compilation-top shared-obj-pos void counting-port)) (got-here 4) ; Write the compiled form header (write-bytes #"#~" outp) @@ -129,7 +156,7 @@ ; Actually write the zo (out-symbol-table symbol-table outp) (got-here 6) - (out-compilation-top shared-obj-pos outp) + (out-compilation-top shared-obj-pos void outp) (got-here 7) (void)) @@ -390,7 +417,7 @@ (vector p (encode-certs certs)) p))])) -(define-struct out (s shared-index encoded-wraps)) +(define-struct out (s shared-index shared-unsee encoded-wraps)) (define (out-shared v out k) (if (shareable? v) (let ([v ((out-shared-index out) v)]) @@ -438,17 +465,22 @@ (define (or-pred? v . ps) (ormap (lambda (?) (? v)) ps)) - (define quoting? (make-parameter #f)) (define (shareable? v) - (not (or (quoting?) (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) + (define never-share-this? + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)) + (define always-share-this? + (or-pred? v closure?)) + (or always-share-this? + (if (quoting?) + #f + (not never-share-this?)))) (define (maybe-same-as-fixnum? v) (and (exact-integer? v) (and (v . >= . -1073741824) (v . <= . 1073741823)))) - (define (out-anything v out) (out-shared v out @@ -479,11 +511,13 @@ (unless (zero? phase) (out-number -2 out)) (out-number pos out)] - [(struct indirect (val)) (out-anything val out)] + [(struct indirect (val)) + (out-anything val out)] [(struct closure (lam gen-id)) (out-byte CPT_CLOSURE out) - (out-number ((out-shared-index out) v) out) - (out-anything lam out)] + (let ([pos ((out-shared-index out) v #:error? #t)]) + (out-number pos out) + (out-anything lam out))] [(struct prefix (num-lifts toplevels stxs)) (out-marshaled prefix-type-num @@ -668,7 +702,7 @@ expr out)] [(protected-symref v) - (out-anything ((out-shared-index out) v) out)] + (out-anything ((out-shared-index out) v #:error? #t) out)] [(and (? symbol?) (not (? symbol-interned?))) (out-as-bytes v #:before-length (if (symbol-unreadable? v) 0 1) @@ -706,18 +740,29 @@ (out-byte CPT_BOX out) (out-anything (unbox v) out)] [(? pair?) + ; This code will not turn two different lists that share a common tail + ; e.g. (list* 1 l) and (list* 2 l) + ; into a form that puts l into the symbol table + ; (when that is possible) + + ; In contrast, if we always use CPT_PAIR, then it would + + ; Unfortunately, detecting this situation during the traversal + ; phase, without introducing false sharing, is difficult. + ; We had an implementation (see the history), but it was buggy. (define (list-length-before-cycle/improper-end l) - (let loop ([len 1] [l (cdr l)]) + (let loop ([len 0] [l l] [seen (set)]) (cond - [((out-shared-index out) l #:share #f) + [(set-member? seen l) (values len #f)] [(null? l) (values len #t)] [(pair? l) - (loop (add1 len) (cdr l))] + (loop (add1 len) (cdr l) (set-add seen l))] [else (values len #f)]))) (define-values (len proper?) (list-length-before-cycle/improper-end v)) + (define (print-contents-as-proper) (for ([e (in-list v)]) (out-anything e out))) @@ -787,28 +832,33 @@ (vector-set! pre-v 0 (prefab-struct-key v)) (out-byte CPT_PREFAB out) (out-anything pre-v out)] - [else + [(quoted qv) (out-byte CPT_QUOTE out) - (if (quoted? v) - (parameterize ([quoting? #t]) - (out-anything (quoted-v v) out)) - (let ([s (open-output-bytes)]) - (parameterize ([pretty-print-size-hook - (lambda (v mode port) - (and (path? v) - (let ([v (make-relative v)]) - (+ 2 (let ([p (open-output-bytes)]) - (write (path->bytes v) p) - (bytes-length (get-output-bytes p)))))))] - [pretty-print-print-hook - (lambda (v mode port) - (display "#^" port) - (write (path->bytes (make-relative v)) port))]) - (pretty-write v s)) - (out-byte CPT_ESCAPE out) - (let ([bstr (get-output-bytes s)]) - (out-number (bytes-length bstr) out) - (out-bytes bstr out))))])))) + (parameterize ([quoting? #t]) + (out-anything qv out))] + [(or (? path?) ; XXX Why not use CPT_PATH? + (? regexp?) + (? byte-regexp?) + (? number?)) + (out-byte CPT_QUOTE out) + (define s (open-output-bytes)) + (parameterize + ([pretty-print-size-hook + (lambda (v mode port) + (and (path? v) + (let ([v (make-relative v)]) + (+ 2 (let ([p (open-output-bytes)]) + (write (path->bytes v) p) + (bytes-length (get-output-bytes p)))))))] + [pretty-print-print-hook + (lambda (v mode port) + (display "#^" port) + (write (path->bytes (make-relative v)) port))]) + (pretty-write v s)) + (out-byte CPT_ESCAPE out) + (define bstr (get-output-bytes s)) + (out-number (bytes-length bstr) out) + (out-bytes bstr out)])))) (define-struct module-decl (content)) @@ -969,11 +1019,10 @@ (define-struct quoted (v)) (define (protect-quote v) - (if (or (pair? v) (vector? v) (and (not zo?) (prefab-struct-key v)) (box? v) (hash? v) (svector? v)) + (if (or (pair? v) (vector? v) (and (not (zo? v)) (prefab-struct-key v)) (box? v) (hash? v) (svector? v)) (make-quoted v) v)) - (define-struct svector (vec)) (define (make-relative v) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 28d0bd4ac5..0b441796c0 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -837,6 +837,10 @@ [lst (for/list ([i (in-range n)]) (read-compact cp))]) (vector->immutable-vector (list->vector lst)))] + [(pair) + (let* ([a (read-compact cp)] + [d (read-compact cp)]) + (cons a d))] [(list) (let ([len (read-compact-number cp)]) (let loop ([i len]) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 79ab23f1e7..c84eac9dc6 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -27,7 +27,8 @@ (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] - [x (indirect (closure + [x (indirect + (closure (lam 'name empty 0 From 78d5856d4dd7fd204b001edf91081406c4636269 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 6 Sep 2010 23:39:05 -0600 Subject: [PATCH 179/466] never sharing hashes and trace debugging original commit: 0d136ba4c774548828cec985d7d89e4769a6a01a --- collects/compiler/zo-marshal.rkt | 26 ++++++++++++++++++++++++-- collects/tests/compiler/zo-exs.rkt | 14 ++++++++++---- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 74eabb5f48..7b1dbbc9e7 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -77,6 +77,7 @@ (out-compilation-top (λ (v #:error? [error? #f]) (cond + [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] [(closure? v) (let ([pos (share! v)]) (if (encountered? v) @@ -101,6 +102,8 @@ (define-values (symbol-table shared-obj-pos) (create-symbol-table)) (got-here 2) + + #;(printf "symtab[998] = ~a\n" (vector-ref symbol-table 998)) #;(for ([v (in-vector symbol-table)]) (printf "v = ~a~n" v)) @@ -469,7 +472,7 @@ (define (shareable? v) (define never-share-this? - (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)) + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? )) (define always-share-this? (or-pred? v closure?)) (or always-share-this? @@ -481,7 +484,26 @@ (and (exact-integer? v) (and (v . >= . -1073741824) (v . <= . 1073741823)))) +(define (current-type-trace) + (reverse (continuation-mark-set->list (current-continuation-marks) 'zo))) + +(define (typeof v) + (cond + [(pair? v) 'cons] + [(hash? v) 'hash] + [(prefab-struct-key v) => (λ (key) key)] + [(vector? v) 'vector] + [else v])) + +(define-syntax with-type-trace + (syntax-rules () + [(_ v body ...) + (begin body ...) + #;(with-continuation-mark 'zo (typeof v) + (begin0 (begin body ...) (void)))])) + (define (out-anything v out) + (with-type-trace v (out-shared v out (λ () @@ -858,7 +880,7 @@ (out-byte CPT_ESCAPE out) (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) - (out-bytes bstr out)])))) + (out-bytes bstr out)]))))) (define-struct module-decl (content)) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index c84eac9dc6..a66ed0f39e 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -23,7 +23,7 @@ (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] @@ -84,12 +84,18 @@ (prefix 0 empty empty) (list (current-directory)))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) - (cons #hasheq() - #hasheq()))) + (cons #hash() + #hash()))) + + (roundtrip + (compilation-top + 0 + (prefix 0 empty empty) + #hash())) #;(local [(define (hash-test make-hash-placeholder) (roundtrip From 785033b8806a9986a1abfccf92dd698aeeea85bc Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 8 Sep 2010 15:27:33 -0600 Subject: [PATCH 180/466] Removing pieces of zo-test-worker we dont care about original commit: e94823b82c0c87227e414466a98c9007b4920d5b --- collects/tests/compiler/zo-test-worker.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt index 0a698fe246..022d661058 100644 --- a/collects/tests/compiler/zo-test-worker.rkt +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -210,8 +210,8 @@ (if serious? (esc #f) #f))]) - e)]) - (record! (success 'step1)) + (begin0 e + (record! (success 'step1))))]) (run/stages* file . rst)))])) (define-syntax-rule (define-stages (run! file) @@ -235,22 +235,22 @@ [compare-parsed-to-parsed-marshalled #f (equal?/why-not parse-orig parse-marshalled)] - [marshal-marshalled + #;[marshal-marshalled #t (zo-marshal parse-marshalled)] - [compare-marshalled-to-marshalled-marshalled + #;[compare-marshalled-to-marshalled-marshalled #f (bytes-not-equal?-error marshal-parsed marshal-marshalled)] #;[replace-with-marshalled #t (replace-file file marshal-marshalled)] - [decompile-parsed + #;[decompile-parsed #t (decompile parse-orig)] [c-parse-marshalled #t (read-compiled-bytes marshal-parsed)] - [compare-orig-to-marshalled + #;[compare-orig-to-marshalled #f (bytes-not-equal?-error read-orig marshal-parsed)]) @@ -260,7 +260,7 @@ (define (run-test file) (run-with-limit file - (* 1024 1024 128) + (* 1024 1024 1024) (lambda () (run! file))) (write (reverse RESULTS))) From 4d82ab734ed0b280fd74dd77b187f794f5f6dce8 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 8 Sep 2010 15:33:04 -0600 Subject: [PATCH 181/466] Changing memory limit original commit: 407a36c9d21dacfb3b6a5649072be96b532f53f5 --- collects/tests/compiler/zo-test-worker.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt index 022d661058..e73f0630bb 100644 --- a/collects/tests/compiler/zo-test-worker.rkt +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -260,7 +260,7 @@ (define (run-test file) (run-with-limit file - (* 1024 1024 1024) + (* 1024 1024 512) (lambda () (run! file))) (write (reverse RESULTS))) From 1f08f652826758e5e59a0fb854db9cb898bd8eb1 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 12:41:51 -0600 Subject: [PATCH 182/466] removing debugging information original commit: 6338a97e0a05c43d4c97aaefc9278d28e437e62d --- collects/compiler/zo-marshal.rkt | 32 ++++++-------------------------- collects/compiler/zo-parse.rkt | 13 ------------- 2 files changed, 6 insertions(+), 39 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 7b1dbbc9e7..76a5731737 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -24,10 +24,6 @@ (zo-marshal-to top bs) (get-output-bytes bs)) -(define (got-here n) - (void) - #;(printf "got here: ~a~n" n)) - (define (zo-marshal-to top outp) ; XXX: wraps were encoded in traverse, now needs to be handled when writing @@ -60,14 +56,10 @@ (when (= how-many-encounters 1) (hash-set! encountered v 0))) (define (shared-obj-pos v #:error? [error? #f]) - (define pos - (hash-ref shared v - (if error? - (λ () (error 'symref "~e not in symbol table" v)) - #f))) - #;(when (closure? v) - (printf "Looking up ~a, got ~a\n" v pos)) - pos) + (hash-ref shared v + (if error? + (λ () (error 'symref "~e not in symbol table" v)) + #f))) (define (share! v) ; XXX this doesn't always set something, probably should be refactored (or (shared-obj-pos v) (let ([pos (add1 (hash-count shared))]) @@ -83,7 +75,7 @@ (if (encountered? v) pos (encounter! v)))] - #;[error? ; If we would error if this were not present, then we must share it + [error? ; If we would error if this were not present, then we must share it (encounter! v) (share! v)] [(encountered? v) @@ -98,14 +90,8 @@ (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) (values symbol-table shared-obj-pos)) - (got-here 1) (define-values (symbol-table shared-obj-pos) (create-symbol-table)) - (got-here 2) - - #;(printf "symtab[998] = ~a\n" (vector-ref symbol-table 998)) - #;(for ([v (in-vector symbol-table)]) - (printf "v = ~a~n" v)) ; vector output-port -> (listof number) number ; writes symbol-table to outp @@ -125,16 +111,14 @@ [i (in-naturals)]) (begin0 (file-position outp) - #;(printf "Out ~a -->" i) #;(pretty-print v) (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void wrapped)))) (file-position outp))) ; Calculate file positions (define counting-port (open-output-nowhere)) (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) - (got-here 3) (define all-forms-length (out-compilation-top shared-obj-pos void counting-port)) - (got-here 4) + ; Write the compiled form header (write-bytes #"#~" outp) @@ -155,12 +139,9 @@ (write-bytes (int->bytes post-shared) outp) ; This is where the file should end (write-bytes (int->bytes all-forms-length) outp) - (got-here 5) ; Actually write the zo (out-symbol-table symbol-table outp) - (got-here 6) (out-compilation-top shared-obj-pos void outp) - (got-here 7) (void)) ;; ---------------------------------------- @@ -700,7 +681,6 @@ (out-byte CPT_APPLICATION out) (out-number len out))) (for-each (lambda (e) - #;(printf "here: ~a~n" e) (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 0b441796c0..6a8edd6032 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -32,8 +32,6 @@ ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms -(define debug-symrefs #f) - (define (read-toplevel v) (define SCHEME_TOPLEVEL_CONST #x01) (define SCHEME_TOPLEVEL_READY #x02) @@ -981,8 +979,6 @@ (placeholder-set! (vector-ref (cport-symtab cp) i) v)) (define (symtab-lookup cp i) - (when (mark-parameter-first read-sym-mark) - (dict-update! debug-symrefs (mark-parameter-first read-sym-mark) (λ (last) (cons i last)) empty)) (vector-ref (cport-symtab cp) i)) (require unstable/markparam) @@ -1042,20 +1038,11 @@ (define symtab (build-vector symtabsize (λ (i) (make-placeholder nr)))) - (set! debug-symrefs (make-vector symtabsize empty)) - (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) - #;(for ([i (in-naturals)] - [v (in-vector debug-symrefs)]) - (printf "~a: ~a~n" i v)) - #;(printf "SYMBOL TABLE(~a):~n~n" symtabsize) - #;(for ([i (in-naturals)] - [v (in-vector (cport-symtab cp))]) - (printf "~a: ~s~n~n" i (placeholder-get v))) (set-cport-pos! cp shared-size) (make-reader-graph (read-marshalled 'compilation-top-type cp)))) From 428d1d383d413f9295b67645c45fd024c0932b93 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 12:42:34 -0600 Subject: [PATCH 183/466] re-enabling tests original commit: 1cb11ce6cc7ef7d5a7c7d2e3e6c9f1a6cffed4ff --- collects/tests/compiler/zo-exs.rkt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index a66ed0f39e..34ca2e4c2e 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -19,10 +19,11 @@ (test - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) + ; XXX This should work, but closures have a field that is gensym'ed #;(roundtrip (compilation-top 0 (prefix 0 empty empty) @@ -42,6 +43,7 @@ (placeholder-set! ph x) (make-reader-graph x)))) + ; This should work, but module-path-index-join doesn't create equal? module-path-index's #;(roundtrip (compilation-top 0 @@ -74,12 +76,12 @@ (toplevel 0 0 #f #f) #(racket/language-info get-info #f) #t))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) From 4c5dfd88af537540123cf34a423ffc203ec980c5 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 12:58:56 -0600 Subject: [PATCH 184/466] fixing pr11036 by adding plain certificates original commit: 170ab47dc2bd1fa2232c30f33062ac8e4e0c1a26 --- collects/compiler/zo-marshal.rkt | 4 +++- collects/compiler/zo-parse.rkt | 4 +++- collects/compiler/zo-structs.rkt | 3 +++ 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 76a5731737..e9403b252c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -356,7 +356,9 @@ [(struct certificate:nest (m1 m2)) (list* (encode-mark-map m1) (encode-mark-map m2))] [(struct certificate:ref (val m)) - (list* #f (make-protected-symref val) (encode-mark-map m))])) + (list* #f (make-protected-symref val) (encode-mark-map m))] + [(struct certificate:plain (m)) + (encode-mark-map m)])) (define (encode-wrapped w) (match w diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 6a8edd6032..e6e677700e 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -524,7 +524,9 @@ (symtab-lookup cp symref) (decode-mark-map alist))] [(list* (? list? nested) alist) - (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))]))) + (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))] + [alist + (make-certificate:plain (decode-mark-map alist))]))) (define stx-memo (make-memo)) ; XXX More memo use diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index acb2476831..4aba9f8ded 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -63,6 +63,9 @@ (define-form-struct (certificate:ref certificate) ([val any/c] [map mark-map?])) +(define-form-struct (certificate:plain certificate) + ([map mark-map?])) + (define-form-struct wrap ()) (define-form-struct wrapped ([datum any/c] From aa0d3e18aedb681252e10944d32c5bc38b5a1865 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 13:51:38 -0600 Subject: [PATCH 185/466] fixing pr11175, added only-rest-arg-not-used flag original commit: 3433af0a3003f86c61cd4e81e53cb8e604b46238 --- collects/compiler/zo-marshal.rkt | 4 +++- collects/compiler/zo-parse.rkt | 7 +++++-- collects/compiler/zo-structs.rkt | 4 ++-- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e9403b252c..0e219725fb 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -970,7 +970,9 @@ (let* ([l (protect-quote body)] [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) (ormap (lambda (t) (memq t '(flonum))) closure-types))] - [num-all-params ((if rest? add1 values) num-params)] + [num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags))) + (add1 num-params) + num-params)] [l (cons (make-svector (if any-refs? (list->vector (append diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index e6e677700e..cf00f05ce9 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -117,8 +117,11 @@ (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) - (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result))) - ((if rest? sub1 values) num-params) + (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) + (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) + (if (and rest? (num-params . > . 0)) + (sub1 num-params) + num-params) arg-types rest? (if (= closure-size (vector-length closed-over)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 4aba9f8ded..1e62a623d7 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -135,8 +135,8 @@ [internal-context (or/c #f #t stx?)])) (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] - [flags (listof (or/c 'preserves-marks 'is-method 'single-result))] - [num-params integer?] ; should be exact-nonnegative-integer? + [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))] + [num-params exact-nonnegative-integer?] [param-types (listof (or/c 'val 'ref 'flonum))] [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] From be19dcb79d4179a78cb7f465c5f2aea2c1abed7f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 10 Sep 2010 09:48:53 -0400 Subject: [PATCH 186/466] Use "" instead of a misleading "", improve doc line for `--collect'. original commit: 41812ace0f128f4a7681b8fcb731b04952643f17 --- collects/compiler/commands/pack.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/compiler/commands/pack.rkt b/collects/compiler/commands/pack.rkt index 852ee99d74..8a2fa32a50 100644 --- a/collects/compiler/commands/pack.rkt +++ b/collects/compiler/commands/pack.rkt @@ -23,7 +23,7 @@ (command-line #:program (short-program+command-name) #:once-each - [("--collect") "Pack collections instead of files and directories" + [("--collect") "s specify collections instead of files/dirs" (collection? #t)] [("--plt-name") name "Set the printed describing the archive" (plt-name name)] @@ -45,8 +45,8 @@ #:once-each [("-v") "Verbose mode" (verbose #t)] - #:args (dest-file . file) - (values dest-file file))) + #:args (dest-file . path) + (values dest-file path))) (if (not (collection?)) ;; Files and directories From d2ad91ae380c746e70b02d5eac30903123d74f1a Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 16 Sep 2010 12:13:15 -0600 Subject: [PATCH 187/466] removing indirects from zo handling original commit: c88eb704c7a4894fefecf353a970c877ea5dedf7 --- collects/compiler/decompile.rkt | 7 --- collects/compiler/zo-marshal.rkt | 2 - collects/compiler/zo-parse.rkt | 42 ++++++++--------- collects/compiler/zo-structs.rkt | 52 ++++++++++------------ collects/tests/compiler/zo-test-worker.rkt | 2 +- 5 files changed, 45 insertions(+), 60 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index b592d15776..4af6bb5d08 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -160,8 +160,6 @@ (extract-name name)] [(struct closure (lam gen-id)) (extract-id lam)] - [(struct indirect (v)) - (extract-id v)] [else #f])) (define (extract-ids! body ids) @@ -288,15 +286,10 @@ (begin (hash-set! closed gen-id #t) `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))] - [(struct indirect (val)) - (if (closure? val) - (decompile-expr val globs stack closed) - '???)] [else `(quote ,expr)])) (define (decompile-lam expr globs stack closed) (match expr - [(struct indirect (val)) (decompile-lam val globs stack closed)] [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 0e219725fb..afd0a0b084 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -516,8 +516,6 @@ (unless (zero? phase) (out-number -2 out)) (out-number pos out)] - [(struct indirect (val)) - (out-anything val out)] [(struct closure (lam gen-id)) (out-byte CPT_CLOSURE out) (let ([pos ((out-shared-index out) v #:error? #t)]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index cf00f05ce9..32d98ef065 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -348,9 +348,9 @@ (cons 'free-id-info-type read-free-id-info)))) (define (get-reader type) - (or (hash-ref type-readers type #f) - (lambda (v) - (error 'read-marshalled "reader for ~a not implemented" type)))) + (hash-ref type-readers type + (λ () + (error 'read-marshalled "reader for ~a not implemented" type)))) ;; ---------------------------------------- ;; Lowest layer of bytecode parsing @@ -732,6 +732,9 @@ (define (parse-module-path-index cp s) s) + +(define (error-when-false v) + (or v (error "app rator is false"))) ;; ---------------------------------------- ;; Main parsing loop @@ -927,7 +930,7 @@ [(small-marshalled) (read-marshalled (- ch cpt-start) cp)] [(small-application2) - (make-application (read-compact cp) + (make-application (error-when-false (read-compact cp)) (list (read-compact cp)))] [(small-application3) (make-application (read-compact cp) @@ -935,29 +938,26 @@ (read-compact cp)))] [(small-application) (let ([c (add1 (- ch cpt-start))]) - (make-application (read-compact cp) + (make-application (error-when-false (read-compact cp)) (for/list ([i (in-range (sub1 c))]) (read-compact cp))))] [(application) (let ([c (read-compact-number cp)]) - (make-application (read-compact cp) + (make-application (error-when-false (read-compact cp)) (for/list ([i (in-range c)]) (read-compact cp))))] - [(closure) ; XXX The use of indirect may be an artifact from pre-placeholder days - (let* ([l (read-compact-number cp)] - [ind (make-indirect #f)]) - (symtab-write! cp l ind) - (let* ([v (read-compact cp)] - [cl (make-closure v - ; XXX Why call gensym here? - (gensym - (let ([s (lam-name v)]) - (cond - [(symbol? s) s] - [(vector? s) (vector-ref s 0)] - [else 'closure]))))]) - (set-indirect-v! ind cl) - ind))] + [(closure) + (read-compact-number cp) ; symbol table pos. our marshaler will generate this + (let ([v (read-compact cp)]) + (make-closure + v + ; XXX Why call gensym here? + (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure])))))] [(svector) (read-compact-svector cp (read-compact-number cp))] [(small-svector) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 1e62a623d7..d3933aa349 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -82,11 +82,7 @@ (define-form-struct form ()) (define-form-struct (expr form) ()) -;; A static closure can refer directly to itself, creating a cycle -; XXX: this might not be needed anymore with the current sharing model -(define-struct (indirect zo) ([v #:mutable]) #:prefab) - -(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this +(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? any/c)])) ; compiled code always wrapped with this ;; A provided identifier (define-form-struct provided ([name symbol?] @@ -102,17 +98,17 @@ [const? boolean?] [ready? boolean?])) ; access binding via prefix array (which is on stack) -(define-form-struct (seq form) ([forms (listof (or/c form? indirect? any/c))])) ; `begin' +(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' ;; Definitions (top level or within module): (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? indirect? any/c)])) + [rhs (or/c expr? seq? any/c)])) (define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? indirect? any/c)] + [rhs (or/c expr? seq? any/c)] [prefix prefix?] [max-let-depth exact-nonnegative-integer?])) (define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? indirect? any/c)] + [rhs (or/c expr? seq? any/c)] [prefix prefix?] [max-let-depth exact-nonnegative-integer?])) @@ -125,7 +121,7 @@ (listof provided?)))] [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] - [body (listof (or/c form? indirect? any/c))] + [body (listof (or/c form? any/c))] [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] [unexported (list/c (listof symbol?) (listof symbol?) (listof symbol?))] @@ -142,35 +138,35 @@ [closure-map (vectorof exact-nonnegative-integer?)] [closure-types (listof (or/c 'val/ref 'flonum))] [max-let-depth exact-nonnegative-integer?] - [body (or/c expr? seq? indirect? any/c)])) ; `lambda' + [body (or/c expr? seq? any/c)])) ; `lambda' (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) -(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? indirect?))])) ; each clause is a lam (added indirect) +(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))])) -(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack -(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? indirect? any/c)])) ; create new stack slots +(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack +(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots (define-form-struct (install-value expr) ([count exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [boxes? boolean?] - [rhs (or/c expr? seq? indirect? any/c)] - [body (or/c expr? seq? indirect? any/c)])) ; set existing stack slot(s) -(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? indirect? any/c)])) ; put `letrec'-bound closures into existing stack slots -(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? indirect? any/c)])) ; box existing stack element + [rhs (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) ; set existing stack slot(s) +(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots +(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element (define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack (define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) -(define-form-struct (application expr) ([rator (or/c expr? seq? indirect? any/c)] [rands (listof (or/c expr? seq? indirect? any/c))])) ; function call -(define-form-struct (branch expr) ([test (or/c expr? seq? indirect? any/c)] [then (or/c expr? seq? indirect? any/c)] [else (or/c expr? seq? indirect? any/c)])) ; `if' -(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? indirect? any/c)] - [val (or/c expr? seq? indirect? any/c)] - [body (or/c expr? seq? indirect? any/c)])) ; `with-continuation-mark' -(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? indirect? any/c))])) ; `begin0' -(define-form-struct (splice form) ([forms (listof (or/c form? indirect? any/c))])) ; top-level `begin' +(define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call +(define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if' +(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)] + [val (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' +(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' +(define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' (define-form-struct (varref expr) ([toplevel toplevel?])) ; `#%variable-reference' -(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? indirect? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! -(define-form-struct (apply-values expr) ([proc (or/c expr? seq? indirect? any/c)] [args-expr (or/c expr? seq? indirect? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! +(define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive ;; Top-level `require' @@ -245,8 +241,6 @@ ; XXX better name for 'value' (define-form-struct (mark-barrier wrap) ([value symbol?])) -(provide/contract (struct indirect ([v (or/c closure? #f)]))) - diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt index e73f0630bb..8442fb74f6 100644 --- a/collects/tests/compiler/zo-test-worker.rkt +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -232,7 +232,7 @@ [parse-marshalled #t (zo-parse/bytes marshal-parsed)] - [compare-parsed-to-parsed-marshalled + #;[compare-parsed-to-parsed-marshalled #f (equal?/why-not parse-orig parse-marshalled)] #;[marshal-marshalled From 4830a2d141b3e6ae369c695e61a8ae789ef3133a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 16 Sep 2010 12:45:23 -0600 Subject: [PATCH 188/466] Removing debugging aid original commit: 089e99fac65b3d408041423742adfab0737f202d --- collects/compiler/zo-parse.rkt | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 32d98ef065..000c4efc35 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -733,8 +733,6 @@ (define (parse-module-path-index cp s) s) -(define (error-when-false v) - (or v (error "app rator is false"))) ;; ---------------------------------------- ;; Main parsing loop @@ -930,7 +928,7 @@ [(small-marshalled) (read-marshalled (- ch cpt-start) cp)] [(small-application2) - (make-application (error-when-false (read-compact cp)) + (make-application (read-compact cp) (list (read-compact cp)))] [(small-application3) (make-application (read-compact cp) @@ -938,12 +936,12 @@ (read-compact cp)))] [(small-application) (let ([c (add1 (- ch cpt-start))]) - (make-application (error-when-false (read-compact cp)) + (make-application (read-compact cp) (for/list ([i (in-range (sub1 c))]) (read-compact cp))))] [(application) (let ([c (read-compact-number cp)]) - (make-application (error-when-false (read-compact cp)) + (make-application (read-compact cp) (for/list ([i (in-range c)]) (read-compact cp))))] [(closure) From 52163c7f17a836b429620a6d360a60c492e6a6e5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 19 Oct 2010 15:53:03 -0700 Subject: [PATCH 189/466] Describing architecture a little original commit: 039fc7095addf7670631e0d0e4923b6feeea06f4 --- collects/meta/drdr2/analyzer/analyzer.rkt | 1 + collects/meta/drdr2/master/master.rkt | 1 + 2 files changed, 2 insertions(+) create mode 100644 collects/meta/drdr2/analyzer/analyzer.rkt create mode 100644 collects/meta/drdr2/master/master.rkt diff --git a/collects/meta/drdr2/analyzer/analyzer.rkt b/collects/meta/drdr2/analyzer/analyzer.rkt new file mode 100644 index 0000000000..6f1f7b4de3 --- /dev/null +++ b/collects/meta/drdr2/analyzer/analyzer.rkt @@ -0,0 +1 @@ +#lang racket diff --git a/collects/meta/drdr2/master/master.rkt b/collects/meta/drdr2/master/master.rkt new file mode 100644 index 0000000000..6f1f7b4de3 --- /dev/null +++ b/collects/meta/drdr2/master/master.rkt @@ -0,0 +1 @@ +#lang racket From 1f2e1c66473055e378efea4878988bf88ba9b384 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 21 Sep 2010 12:20:29 -0600 Subject: [PATCH 190/466] moved demodularizer from github to collects and added it to raco original commit: 4676662e4b25f2c43433289433932523bd5c00aa --- collects/compiler/demodularizer/alpha.rkt | 19 ++ collects/compiler/demodularizer/batch.rkt | 127 ++++++++ .../compiler/demodularizer/gc-toplevels.rkt | 275 ++++++++++++++++++ collects/compiler/demodularizer/merge.rkt | 165 +++++++++++ collects/compiler/demodularizer/module.rkt | 35 +++ collects/compiler/demodularizer/mpi.rkt | 30 ++ collects/compiler/demodularizer/nodep.rkt | 178 ++++++++++++ .../demodularizer/update-toplevels.rkt | 97 ++++++ collects/compiler/demodularizer/util.rkt | 56 ++++ 9 files changed, 982 insertions(+) create mode 100644 collects/compiler/demodularizer/alpha.rkt create mode 100644 collects/compiler/demodularizer/batch.rkt create mode 100644 collects/compiler/demodularizer/gc-toplevels.rkt create mode 100644 collects/compiler/demodularizer/merge.rkt create mode 100644 collects/compiler/demodularizer/module.rkt create mode 100644 collects/compiler/demodularizer/mpi.rkt create mode 100644 collects/compiler/demodularizer/nodep.rkt create mode 100644 collects/compiler/demodularizer/update-toplevels.rkt create mode 100644 collects/compiler/demodularizer/util.rkt diff --git a/collects/compiler/demodularizer/alpha.rkt b/collects/compiler/demodularizer/alpha.rkt new file mode 100644 index 0000000000..7ca1b83e1a --- /dev/null +++ b/collects/compiler/demodularizer/alpha.rkt @@ -0,0 +1,19 @@ +#lang racket +(require compiler/zo-parse) + +(define (alpha-vary-ctop top) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (make-compilation-top max-let-depth (alpha-vary-prefix prefix) form)])) +(define (alpha-vary-prefix p) + (struct-copy prefix p + [toplevels + (map (match-lambda + [(and sym (? symbol?)) + (gensym sym)] + [other + other]) + (prefix-toplevels p))])) + +(provide/contract + [alpha-vary-ctop (compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt new file mode 100644 index 0000000000..b8e70bb143 --- /dev/null +++ b/collects/compiler/demodularizer/batch.rkt @@ -0,0 +1,127 @@ +#lang racket +#| +Here's the idea: + +- Take a module's bytecode +- Recursively get all the bytecode for modules that the target requires +- After reading it, prune everything that isn't at phase 0 (the runtime phase) + +- Now that we have all the modules, the next step is to merge them into a single + module +-- Although actually we collapse them into the top-level, not a module +- To do that, we iterate through all the modules doing two things as we go: +-- Incrementing all the global variable references by all the references in all + the modules +--- So if A has 5, then B's start at index 5 and so on +-- Replacing module variable references with the actual global variables + corresponding to those variables +--- So if A's variable 'x' is in global slot 4, then if B refers to it, it + directly uses slot 4, rather than a module-variable slot + +- At that point we have all the module code in a single top-level, but many + toplevels won't be used because a library function isn't really used +- So, we do a "garbage collection" on elements of the prefix +- First, we create a dependency graph of all toplevels and the initial scope +- Then, we do a DFS on the initial scope and keep all those toplevels, throwing + away the construction of everything else + [XXX: This may be broken because of side-effects.] + +- Now we have a small amount code, but because we want to go back to source, + we need to fix it up a bit; because different modules may've used the same + names +- So, we do alpha-renaming, but it's easy because names are only used in the + compilation-top prefix structure + +[TODO] + +- Next, we decompile +- Then, it will pay to do dead code elimination and inlining, etc. +|# + +(require racket/pretty + racket/system + "util.rkt" + "nodep.rkt" + "merge.rkt" + "gc-toplevels.rkt" + "alpha.rkt" + "module.rkt" + compiler/decompile + compiler/zo-marshal + racket/set) + +(define excluded-modules (make-parameter (set))) +(define file-to-batch + (command-line #:program "batch" + #:multi + [("-e" "--exclude-modules") mod + "Exclude a module from being batched" + (excluded-modules (set-add (excluded-modules) mod))] + #:args (filename) filename)) + +(define-values (base name dir?) (split-path file-to-batch)) +(when (or (eq? base #f) dir?) + (error 'batch "Cannot run on directory")) + + +;; Compile +#;(eprintf "Removing existing zo file~n") +#;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) + +#;(when (file-exists? compiled-zo-path) + (delete-file compiled-zo-path)) + +(eprintf "Compiling module~n") +(void (system* (find-executable-path "raco") "make" file-to-batch)) + + +(define merged-source-path (path-add-suffix file-to-batch #".merged.rkt")) +(define-values (merged-source-base merged-source-name _1) (split-path merged-source-path)) +(define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) + +;; Transformations +(eprintf "Removing dependencies~n") +(define-values (batch-nodep top-lang-info top-self-modidx) + (nodep-file file-to-batch (excluded-modules))) + +(eprintf "Merging modules~n") +(define batch-merge + (merge-compilation-top batch-nodep)) + +(eprintf "GC-ing top-levels~n") +(define batch-gcd + (gc-toplevels batch-merge)) + +(eprintf "Alpha-varying top-levels~n") +(define batch-alpha + (alpha-vary-ctop batch-gcd)) + +(define batch-modname + (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) +(eprintf "Modularizing into ~a~n" batch-modname) +(define batch-mod + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-alpha)) + +;; Output +(define batch-final batch-mod) + +(eprintf "Writing merged source~n") +(with-output-to-file + merged-source-path + (lambda () + (pretty-print (decompile batch-final))) + #:exists 'replace) + +(eprintf "Writing merged zo~n") +(void + (with-output-to-file + merged-zo-path + (lambda () + (write-bytes (zo-marshal batch-final))) + #:exists 'replace)) + +(eprintf "Running merged source~n") +(void (system* (find-executable-path "racket") (path->string merged-source-path))) + + + diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt new file mode 100644 index 0000000000..df1d027969 --- /dev/null +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -0,0 +1,275 @@ +#lang racket +(require compiler/zo-parse + "util.rkt") + +; XXX Use efficient set structure +(define (gc-toplevels top) + (match top + [(struct compilation-top (max-let-depth top-prefix form)) + (define lift-start + (prefix-lift-start top-prefix)) + (define max-depgraph-index + (+ (prefix-num-lifts top-prefix) + lift-start)) + (define top-node max-depgraph-index) + (define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty))) + (define build-graph! (make-build-graph! DEP-GRAPH)) + (define _void (build-graph! (list top-node) form)) + (define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node)) + (define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node + (define ordered-stxs (sort stxs <=)) + (define (lift? i) (lift-start . <= . i)) + (define-values (lifts normal-tls) (partition lift? ordered-used-tls)) + (define new-prefix + (make-prefix + (length lifts) + (for/list ([i normal-tls]) + (list-ref (prefix-toplevels top-prefix) i)) + (for/list ([i ordered-stxs]) + (list-ref (prefix-stxs top-prefix) i)))) + (define new-lift-start + (prefix-lift-start new-prefix)) + ; XXX This probably breaks max-let-depth + (define new-form + ((gc-toplevels-form + (lambda (pos) (index<=? pos ordered-used-tls)) + (lambda (pos) + (if (lift? pos) + (+ new-lift-start (index<=? pos lifts)) + (index<=? pos normal-tls))) + (lambda (stx-pos) + (index<=? stx-pos ordered-stxs)) + (prefix-syntax-start new-prefix)) + form)) + (eprintf "Total TLS: ~S~n" (length normal-tls)) + (eprintf "Used TLS: ~S~n" normal-tls) + (eprintf "Total lifts: ~S~n" (length lifts)) + (eprintf "Used lifts: ~S~n" lifts) + (eprintf "Total stxs: ~S~n" (length stxs)) + (eprintf "Used stxs: ~S~n" ordered-stxs) + (make-compilation-top + max-let-depth + new-prefix + new-form)])) + +(define-struct refs (tl stx) #:transparent) + +(define (make-build-graph! DEP-GRAPH) + (define (build-graph!* form lhs) + (match form + [(struct def-values (ids rhs)) + (define new-lhs (map toplevel-pos ids)) + ; If we require one, we should require all, so make them reference each other + (for-each (lambda (tl) (build-graph! new-lhs tl)) ids) + (build-graph! new-lhs rhs)] + [(? def-syntaxes?) + (error 'build-graph "Doesn't handle syntax")] + [(? def-for-syntax?) + (error 'build-graph "Doesn't handle syntax")] + [(struct req (reqs dummy)) + (build-graph! lhs dummy)] + [(? mod?) + (error 'build-graph "Doesn't handle modules")] + [(struct seq (forms)) + (for-each (lambda (f) (build-graph! lhs f)) forms)] + [(struct splice (forms)) + (for-each (lambda (f) (build-graph! lhs f)) forms)] + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + (build-graph! lhs body)] + [(and c (struct closure (code gen-id))) + (build-graph! lhs code)] + [(and cl (struct case-lam (name clauses))) + (for-each (lambda (l) (build-graph! lhs l)) + clauses)] + [(struct let-one (rhs body flonum? unused?)) + (build-graph! lhs rhs) + (build-graph! lhs body)] + [(and f (struct let-void (count boxes? body))) + (build-graph! lhs body)] + [(and f (struct install-value (_ _ _ rhs body))) + (build-graph! lhs rhs) + (build-graph! lhs body)] + [(struct let-rec (procs body)) + (for-each (lambda (l) (build-graph! lhs l)) procs) + (build-graph! lhs body)] + [(and f (struct boxenv (_ body))) + (build-graph! lhs body)] + [(and f (struct toplevel (_ pos _ _))) + (for-each (lambda (lhs) + (dict-update! DEP-GRAPH lhs + (match-lambda + [(struct refs (tls stxs)) + (make-refs (list* pos tls) stxs)]))) + lhs)] + [(and f (struct topsyntax (_ pos _))) + (for-each (lambda (lhs) + (dict-update! DEP-GRAPH lhs + (match-lambda + [(struct refs (tls stxs)) + (make-refs tls (list* pos stxs))]))) + lhs)] + [(struct application (rator rands)) + (for-each (lambda (f) (build-graph! lhs f)) + (list* rator rands))] + [(struct branch (test then else)) + (for-each (lambda (f) (build-graph! lhs f)) + (list test then else))] + [(struct with-cont-mark (key val body)) + (for-each (lambda (f) (build-graph! lhs f)) + (list key val body))] + [(struct beg0 (seq)) + (for-each (lambda (f) (build-graph! lhs f)) + seq)] + [(struct varref (tl)) + (build-graph! lhs tl)] + [(and f (struct assign (id rhs undef-ok?))) + (build-graph! lhs id) + (build-graph! lhs rhs)] + [(struct apply-values (proc args-expr)) + (build-graph! lhs proc) + (build-graph! lhs args-expr)] + [(and f (struct primval (id))) + (void)] + [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + (void)] + [(and v (not (? form?))) + (void)])) + (define build-graph!** (build-form-memo build-graph!* #:void? #t)) + (define (build-graph! lhs form) (build-graph!** form lhs)) + build-graph!) + +(define (graph-dfs g start-node) + (define visited? (make-hasheq)) + (define (visit-tl n tls stxs) + (if (hash-has-key? visited? n) + (values tls stxs) + (match (dict-ref g n) + [(struct refs (n-tls n-stxs)) + (hash-set! visited? n #t) + (local + [(define-values (new-tls1 new-stxs1) + (for/fold ([new-tls tls] + [new-stxs stxs]) + ([tl (in-list n-tls)]) + (visit-tl tl new-tls new-stxs))) + (define new-stxs2 + (for/fold ([new-stxs new-stxs1]) + ([stx (in-list n-stxs)]) + (define this-stx (visit-stx stx)) + (if this-stx + (list* this-stx new-stxs) + new-stxs)))] + (values (list* n new-tls1) + new-stxs2))]))) + (define stx-visited? (make-hasheq)) + (define (visit-stx n) + (if (hash-has-key? stx-visited? n) + #f + (begin (hash-set! stx-visited? n #t) + n))) + (visit-tl start-node empty empty)) + +; index<=? : number? (listof number?) -> (or/c number? false/c) +; returns the index of n in l and assumes that l is sorted by <= +(define (index<=? n l) + (match l + [(list) #f] + [(list-rest f l) + (cond + [(= n f) + 0] + [(< n f) + #f] + [else + (let ([rec (index<=? n l)]) + (if rec (add1 rec) rec))])])) + +(define (identity x) x) +(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt) + (define (inner-update form) + (match form + [(struct def-values (ids rhs)) + (if (ormap (compose keep? toplevel-pos) ids) + (make-def-values (map update ids) + (update rhs)) + #f)] + [(? def-syntaxes?) + (error 'gc-tls "Doesn't handle syntax")] + [(? def-for-syntax?) + (error 'gc-tls "Doesn't handle syntax")] + [(struct req (reqs dummy)) + (make-req reqs (update dummy))] + [(? mod?) + (error 'gc-tls "Doesn't handle modules")] + [(struct seq (forms)) + (make-seq (filter identity (map update forms)))] + [(struct splice (forms)) + (make-splice (filter identity (map update forms)))] + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + (struct-copy lam l + [body (update body)])] + [(and c (struct closure (code gen-id))) + (struct-copy closure c + [code (update code)])] + [(and cl (struct case-lam (name clauses))) + (struct-copy case-lam cl + [clauses (map update clauses)])] + [(struct let-one (rhs body flonum? unused?)) + (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is flonum? okay here? + [(and f (struct let-void (count boxes? body))) + (struct-copy let-void f + [body (update body)])] + [(and f (struct install-value (_ _ _ rhs body))) + (struct-copy install-value f + [rhs (update rhs)] + [body (update body)])] + [(struct let-rec (procs body)) + (make-let-rec (map update procs) (update body))] + [(and f (struct boxenv (_ body))) + (struct-copy boxenv f [body (update body)])] + [(and f (struct toplevel (_ pos _ _))) + (struct-copy toplevel f + [pos (update-tl pos)])] + [(and f (struct topsyntax (_ pos _))) + (struct-copy topsyntax f + [pos (update-ts pos)] + [midpt new-ts-midpt])] + [(struct application (rator rands)) + (make-application + (update rator) + (map update rands))] + [(struct branch (test then else)) + (make-branch + (update test) + (update then) + (update else))] + [(struct with-cont-mark (key val body)) + (make-with-cont-mark + (update key) + (update val) + (update body))] + [(struct beg0 (seq)) + (make-beg0 (map update seq))] + [(struct varref (tl)) + (make-varref (update tl))] + [(and f (struct assign (id rhs undef-ok?))) + (struct-copy assign f + [id (update id)] + [rhs (update rhs)])] + [(struct apply-values (proc args-expr)) + (make-apply-values + (update proc) + (update args-expr))] + [(and f (struct primval (id))) + f] + [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + f] + [(and v (not (? form?))) + v] + )) + (define update + (build-form-memo inner-update)) + update) + +(provide/contract + [gc-toplevels (compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt new file mode 100644 index 0000000000..33187add17 --- /dev/null +++ b/collects/compiler/demodularizer/merge.rkt @@ -0,0 +1,165 @@ +#lang racket +(require compiler/zo-parse + "util.rkt" + "mpi.rkt" + "nodep.rkt" + "update-toplevels.rkt") + +(define MODULE-TOPLEVEL-OFFSETS (make-hash)) + +(define (merge-compilation-top top) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (define-values (new-max-let-depth new-prefix gen-new-forms) + (merge-form max-let-depth prefix form)) + (define total-tls (length (prefix-toplevels new-prefix))) + (define total-stxs (length (prefix-stxs new-prefix))) + (define total-lifts (prefix-num-lifts new-prefix)) + (eprintf "max-let-depth ~S to ~S~n" max-let-depth new-max-let-depth) + (eprintf "total toplevels ~S~n" total-tls) + (eprintf "total stxs ~S~n" total-stxs) + (eprintf "num-lifts ~S~n" total-lifts) + (make-compilation-top + new-max-let-depth new-prefix + (make-splice (gen-new-forms new-prefix)))] + [else (error 'merge "unrecognized: ~e" top)])) + +(define (merge-forms max-let-depth prefix forms) + (if (empty? forms) + (values max-let-depth prefix (lambda _ empty)) + (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] + [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) + (values rmax-let-depth + rprefix + (lambda args + (append (apply gen-fform args) + (apply gen-rforms args))))))) + +(define (merge-form max-let-depth prefix form) + (match form + [(? mod?) + (merge-module max-let-depth prefix form)] + [(struct seq (forms)) + (merge-forms max-let-depth prefix forms)] + [(struct splice (forms)) + (merge-forms max-let-depth prefix forms)] + [else + (values max-let-depth prefix (lambda _ (list form)))])) + +(define (merge-prefix root-prefix mod-prefix) + (match root-prefix + [(struct prefix (root-num-lifts root-toplevels root-stxs)) + (match mod-prefix + [(struct prefix (mod-num-lifts mod-toplevels mod-stxs)) + (make-prefix (+ root-num-lifts mod-num-lifts) + (append root-toplevels mod-toplevels) + (append root-stxs mod-stxs))])])) + +(define (compute-new-modvar mv rw) + (match mv + [(struct module-variable (modidx sym pos phase)) + (match rw + [(struct modvar-rewrite (self-modidx provide->toplevel)) + (eprintf "Rewriting ~a of ~S~n" pos (mpi->path* modidx)) + (+ (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda () + (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) + (provide->toplevel sym pos))])])) + +(define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) + (define-values + (i new-toplevels remap) + (for/fold ([i 0] + [new-toplevels empty] + [remap empty]) + ([tl (in-list mod-toplevels)]) + (match tl + [(and mv (struct module-variable (modidx sym pos phase))) + (define rw (get-modvar-rewrite modidx)) + (unless (or (not phase) (zero? phase)) + (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) + (cond + ; Primitive module like #%paramz + [(symbol? rw) + (eprintf "~S from ~S~n" sym rw) + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))] + [(module-path-index? rw) + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))] + [(modvar-rewrite? rw) + (values i + new-toplevels + (list* (compute-new-modvar mv rw) remap))] + [else + (error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])] + [tl + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))]))) + (values (reverse new-toplevels) + (reverse remap))) + +(define (merge-module max-let-depth top-prefix mod-form) + (match mod-form + [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context)) + (define toplevel-offset (length (prefix-toplevels top-prefix))) + (define topsyntax-offset (length (prefix-stxs top-prefix))) + (define lift-offset (prefix-num-lifts top-prefix)) + (define mod-toplevels (prefix-toplevels mod-prefix)) + (define-values (new-mod-toplevels toplevel-remap) (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) + (define num-mod-toplevels + (length toplevel-remap)) + (define mod-stxs + (length (prefix-stxs mod-prefix))) + (define mod-num-lifts + (prefix-num-lifts mod-prefix)) + (define new-mod-prefix + (struct-copy prefix mod-prefix + [toplevels new-mod-toplevels])) + (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx toplevel-offset) + (unless (= (length toplevel-remap) + (length mod-toplevels)) + (error 'merge-module "Not remapping everything: ~S ~S~n" + mod-toplevels toplevel-remap)) + (eprintf "[~S] Incrementing toplevels by ~a~n" + name + toplevel-offset) + (eprintf "[~S] Incrementing lifts by ~a~n" + name + lift-offset) + (eprintf "[~S] Filtered mod-vars from ~a to ~a~n" + name + (length mod-toplevels) + (length new-mod-toplevels)) + (values (max max-let-depth mod-max-let-depth) + (merge-prefix top-prefix new-mod-prefix) + (lambda (top-prefix) + (eprintf "[~S] Updating top-levels\n" name) + (define top-lift-start (prefix-lift-start top-prefix)) + (define mod-lift-start (prefix-lift-start mod-prefix)) + (define total-lifts (prefix-num-lifts top-prefix)) + (define max-toplevel (+ top-lift-start total-lifts)) + (define update + (update-toplevels + (lambda (n) + (cond + [(mod-lift-start . <= . n) + ; This is a lift + (local [(define which-lift (- n mod-lift-start)) + (define lift-tl (+ top-lift-start lift-offset which-lift))] + (when (lift-tl . >= . max-toplevel) + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) + lift-tl)] + [else + (list-ref toplevel-remap n)])) + (lambda (n) + (+ n topsyntax-offset)) + (prefix-syntax-start top-prefix))) + (map update body)))])) + +(provide/contract + [merge-compilation-top (compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt new file mode 100644 index 0000000000..74d7ccd77b --- /dev/null +++ b/collects/compiler/demodularizer/module.rkt @@ -0,0 +1,35 @@ +#lang racket +(require compiler/zo-parse + "util.rkt") + +(define (->module-path-index s) + (if (module-path-index? s) + s + (module-path-index-join `(quote ,s) #f))) + + +(define (wrap-in-kernel-module name srcname lang-info self-modidx top) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (define-values (reqs new-forms) + (partition req? (splice-forms form))) + (define requires + (map (compose ->module-path-index wrapped-datum stx-encoded req-reqs) reqs)) + (make-compilation-top + 0 + (make-prefix 0 (list #f) empty) + (make-mod name srcname + self-modidx + prefix + empty ; provides + (list (cons 0 requires)) + new-forms + empty ; syntax-body + (list empty empty empty) ; unexported + max-let-depth + (make-toplevel 0 0 #f #f) ; dummy + lang-info + #t))])) + +(provide/contract + [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt new file mode 100644 index 0000000000..ae86a43832 --- /dev/null +++ b/collects/compiler/demodularizer/mpi.rkt @@ -0,0 +1,30 @@ +#lang scheme +(require syntax/modresolve) + +(define current-module-path (make-parameter #f)) + +(define (mpi->string modidx) + (cond + [(symbol? modidx) modidx] + [else + (mpi->path! modidx)])) + +(define MODULE-PATHS (make-hash)) +(define (mpi->path! mpi) + (hash-ref! + MODULE-PATHS mpi + (lambda () + (define _pth + (resolve-module-path-index mpi (current-module-path))) + (if (path? _pth) + (simplify-path _pth #t) + _pth)))) +(define (mpi->path* mpi) + (hash-ref MODULE-PATHS mpi + (lambda () + (error 'mpi->path* "Cannot locate cache of path for ~S~n" mpi)))) + +(provide/contract + [current-module-path (parameter/c path-string?)] + [mpi->path! (module-path-index? . -> . (or/c symbol? path?))] + [mpi->path* (module-path-index? . -> . (or/c symbol? path?))]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt new file mode 100644 index 0000000000..f6878c2c0d --- /dev/null +++ b/collects/compiler/demodularizer/nodep.rkt @@ -0,0 +1,178 @@ +#lang racket +(require compiler/zo-parse + "util.rkt" + "mpi.rkt" + racket/set) + +(define excluded-modules (make-parameter null)) + +(define (nodep-file file-to-batch excluded) + (excluded-modules excluded) + (match (get-nodep-module-code/path file-to-batch 0) + [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) + (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite))])) + +(define (path->comp-top pth) + (call-with-input-file pth zo-parse)) + +(define (excluded? pth) + (set-member? (excluded-modules) (path->string pth))) + +(define MODULE-IDX-MAP (make-hash)) +(define (get-nodep-module-code/index mpi phase) + (define pth (mpi->path! mpi)) + (cond + [(symbol? pth) + (hash-set! MODULE-IDX-MAP pth pth) + pth] + [(excluded? pth) + (hash-set! MODULE-IDX-MAP pth mpi) + mpi] + [else + (get-nodep-module-code/path pth phase)])) +(define (get-modvar-rewrite modidx) + (define pth (mpi->path* modidx)) + (hash-ref MODULE-IDX-MAP pth + (lambda () + (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) + +(define-struct @phase (phase code)) +(define-struct modvar-rewrite (modidx provide->toplevel)) +(define-struct module-code (modvar-rewrite lang-info ctop)) +(define @phase-ctop (compose module-code-ctop @phase-code)) + +(define PHASE*MODULE-CACHE (make-hash)) +(define (get-nodep-module-code/path pth phase) + (define MODULE-CACHE + (hash-ref! PHASE*MODULE-CACHE phase make-hash)) + (if (hash-ref MODULE-CACHE pth #f) + #f + (hash-ref! + MODULE-CACHE pth + (lambda () + (define-values (base file dir?) (split-path pth)) + (define base-directory + (if (path? base) + (path->complete-path base (current-directory)) + (current-directory))) + (define-values (modvar-rewrite lang-info ctop) + (begin + (fprintf (current-error-port) "Load ~S @ ~S~n" pth phase) + (nodep/dir + (parameterize ([current-load-relative-directory base-directory]) + (path->comp-top + (build-compiled-path + base + (path-add-suffix file #".zo")))) + pth + phase))) + (when (and phase (zero? phase)) + (hash-set! MODULE-IDX-MAP pth modvar-rewrite)) + (make-@phase + phase + (make-module-code modvar-rewrite lang-info ctop)))))) + +(define (nodep/dir top pth phase) + (parameterize ([current-module-path pth]) + (nodep top phase))) + +(define (nodep top phase) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase)) + (values modvar-rewrite lang-info (make-compilation-top max-let-depth prefix new-form))] + [else (error 'nodep "unrecognized: ~e" top)])) + +(define (nodep-form form phase) + (if (mod? form) + (local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))] + (values modvar-rewrite lang-info (make-splice mods))) + (error 'nodep-form "Doesn't support non mod forms"))) + +; XXX interning is hack to fix test/add04.ss and provide/contract renaming +(define (intern s) (string->symbol (symbol->string s))) +(define (construct-provide->toplevel prefix provides) + (define provide-ht (make-hasheq)) + (for ([tl (prefix-toplevels prefix)] + [i (in-naturals)]) + (when (symbol? tl) + (hash-set! provide-ht (intern tl) i))) + (lambda (sym pos) + (eprintf "Looking up ~S@~a~n" sym pos) + (hash-ref provide-ht (intern sym) + (lambda () + (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))) + +(define (nodep-module mod-form phase) + (match mod-form + [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) + (define new-prefix prefix) + ; Cache all the mpi paths + (for-each (match-lambda + [(and mv (struct module-variable (modidx sym pos phase))) + (mpi->path! modidx)] + [tl + (void)]) + (prefix-toplevels new-prefix)) + (eprintf "[~S] module-variables: ~S~n" name (length (filter module-variable? (prefix-toplevels new-prefix)))) + (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides)) + lang-info + (append (requires->modlist requires phase) + (if (and phase (zero? phase)) + (begin (eprintf "[~S] lang-info : ~S~n" name lang-info) ; XXX Seems to always be #f now + (list (make-mod name srcname self-modidx new-prefix provides requires body empty + unexported max-let-depth dummy lang-info internal-context))) + (begin (eprintf "[~S] Dropping module @ ~S~n" name phase) + empty))))] + [else (error 'nodep-module "huh?: ~e" mod-form)])) + +(define (+* l r) + (if (and l r) (+ l r) #f)) + +(define (requires->modlist requires current-phase) + (apply append + (map + (match-lambda + [(list-rest req-phase mpis) + (define phase (+* current-phase req-phase)) + (apply append + (map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))]) + requires))) + +(define (all-but-last l) + (reverse (rest (reverse l)))) + +(define REQUIRED (make-hasheq)) +(define (extract-modules ct) + (cond + [(compilation-top? ct) + (match (compilation-top-code ct) + [(and m (? mod?)) + (list m)] + [(struct splice (mods)) + mods])] + [(symbol? ct) + (if (hash-has-key? REQUIRED ct) + empty + (begin + (hash-set! REQUIRED ct #t) + (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))] + [(module-path-index? ct) + (if (hash-has-key? REQUIRED ct) + empty + (begin + (hash-set! REQUIRED ct #t) + (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))] + [(not ct) + empty] + [(@phase? ct) + (extract-modules (@phase-ctop ct))] + [else + (error 'extract-modules "Unknown extraction: ~S~n" ct)])) + +(provide/contract + [struct modvar-rewrite + ([modidx module-path-index?] + [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] + [get-modvar-rewrite (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))] + [nodep-file (path-string? set? . -> . (values compilation-top? lang-info/c module-path-index?))]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt new file mode 100644 index 0000000000..701b4475d8 --- /dev/null +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -0,0 +1,97 @@ +#lang racket +(require compiler/zo-parse + "util.rkt") + +(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) + (define (inner-update form) + (match form + [(struct def-values (ids rhs)) + (make-def-values (map update ids) + (update rhs))] + [(? def-syntaxes?) + (error 'increment "Doesn't handle syntax")] + [(? def-for-syntax?) + (error 'increment "Doesn't handle syntax")] + [(struct req (reqs dummy)) + (make-req reqs (update dummy))] + [(? mod?) + (error 'increment "Doesn't handle modules")] + [(struct seq (forms)) + (make-seq (map update forms))] + [(struct splice (forms)) + (make-splice (map update forms))] + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + (struct-copy lam l + [body (update body)])] + [(and c (struct closure (code gen-id))) + (struct-copy closure c + [code (update code)])] + [(and cl (struct case-lam (name clauses))) + (define new-clauses + (map update clauses)) + (struct-copy case-lam cl + [clauses new-clauses])] + [(struct let-one (rhs body flonum? unused?)) + (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is it okay to just pass in the old value for flonum? + [(and f (struct let-void (count boxes? body))) + (struct-copy let-void f + [body (update body)])] + [(and f (struct install-value (_ _ _ rhs body))) + (struct-copy install-value f + [rhs (update rhs)] + [body (update body)])] + [(struct let-rec (procs body)) + (make-let-rec (map update procs) (update body))] + [(and f (struct boxenv (_ body))) + (struct-copy boxenv f [body (update body)])] + [(and f (struct toplevel (_ pos _ _))) + (struct-copy toplevel f + [pos (toplevel-updater pos)])] + [(and f (struct topsyntax (_ pos _))) + (struct-copy topsyntax f + [pos (topsyntax-updater pos)] + [midpt topsyntax-new-midpt])] + [(struct application (rator rands)) + (make-application + (update rator) + (map update rands))] + [(struct branch (test then else)) + (make-branch + (update test) + (update then) + (update else))] + [(struct with-cont-mark (key val body)) + (make-with-cont-mark + (update key) + (update val) + (update body))] + [(struct beg0 (seq)) + (make-beg0 (map update seq))] + [(struct varref (tl)) + (make-varref (update tl))] + [(and f (struct assign (id rhs undef-ok?))) + (struct-copy assign f + [id (update id)] + [rhs (update rhs)])] + [(struct apply-values (proc args-expr)) + (make-apply-values + (update proc) + (update args-expr))] + [(and f (struct primval (id))) + f] + [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + f] + [(and f (not (? form?))) + f] + )) + (define update + (build-form-memo inner-update)) + update) + +(provide/contract + [update-toplevels + ((exact-nonnegative-integer? . -> . exact-nonnegative-integer?) + (exact-nonnegative-integer? . -> . exact-nonnegative-integer?) + exact-nonnegative-integer? + . -> . + (form? . -> . form?))]) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt new file mode 100644 index 0000000000..7f8c653049 --- /dev/null +++ b/collects/compiler/demodularizer/util.rkt @@ -0,0 +1,56 @@ +#lang racket +(require compiler/zo-parse) + +(define (prefix-syntax-start pre) + (length (prefix-toplevels pre))) + +(define (prefix-lift-start pre) + (define syntax-start (prefix-syntax-start pre)) + (define total-stxs (length (prefix-stxs pre))) + (+ syntax-start total-stxs (if (zero? total-stxs) 0 1))) + +(define (eprintf . args) + (apply fprintf (current-error-port) args)) + +(define (build-form-memo inner-update #:void? [void? #f]) + (define memo (make-hasheq)) + (define (update form . args) + (cond + [(hash-ref memo form #f) + => (λ (x) x)] + [else + (let () + (define ph (make-placeholder #f)) + (hash-set! memo form ph) + (define nv (apply inner-update form args)) + (placeholder-set! ph nv) + nv)])) + (define (first-update form . args) + (define final (apply update form args)) + (make-reader-graph final)) + first-update) + +(define lang-info/c + (or/c #f (vector/c module-path? symbol? any/c))) + + +(define (build-compiled-path base name) + (build-path + (cond [(path? base) base] + [(eq? base 'relative) 'same] + [(eq? base #f) (error 'batch "Impossible")]) + "compiled" + name)) + + +(provide/contract + [prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)] + [prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)] + [eprintf ((string?) () #:rest (listof any/c) . ->* . void)] + [build-form-memo + (((unconstrained-domain-> any/c)) + (#:void? boolean?) + . ->* . + (unconstrained-domain-> any/c))] + [lang-info/c contract?] + [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) \ No newline at end of file From e0e144e210507e19d204b6c2af0657e9de77a922 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 24 Sep 2010 12:49:52 -0600 Subject: [PATCH 191/466] changed eprintfs to log-debug original commit: 3ddda200e80d48ee5bc17c64b5f0ae4f85b0d1c1 --- collects/compiler/commands/info.rkt | 3 ++- collects/compiler/demodularizer/batch.rkt | 20 +++++++------- .../compiler/demodularizer/gc-toplevels.rkt | 12 ++++----- collects/compiler/demodularizer/merge.rkt | 26 +++++++++---------- collects/compiler/demodularizer/nodep.rkt | 10 +++---- 5 files changed, 35 insertions(+), 36 deletions(-) diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 9a3106d696..41b92c0eae 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -7,4 +7,5 @@ ("decompile" compiler/commands/decompile "decompile bytecode" #f) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) - ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f))) + ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f) + ("demod" compiler/demodularizer/batch "produce a whole program from a single module" #f))) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index b8e70bb143..1c685d67ba 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -65,13 +65,13 @@ Here's the idea: ;; Compile -#;(eprintf "Removing existing zo file~n") +#;(log-debug "Removing existing zo file~n") #;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) #;(when (file-exists? compiled-zo-path) (delete-file compiled-zo-path)) -(eprintf "Compiling module~n") +(log-debug "Compiling module~n") (void (system* (find-executable-path "raco") "make" file-to-batch)) @@ -80,39 +80,39 @@ Here's the idea: (define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) ;; Transformations -(eprintf "Removing dependencies~n") +(log-debug "Removing dependencies~n") (define-values (batch-nodep top-lang-info top-self-modidx) (nodep-file file-to-batch (excluded-modules))) -(eprintf "Merging modules~n") +(log-debug "Merging modules~n") (define batch-merge (merge-compilation-top batch-nodep)) -(eprintf "GC-ing top-levels~n") +(log-debug "GC-ing top-levels~n") (define batch-gcd (gc-toplevels batch-merge)) -(eprintf "Alpha-varying top-levels~n") +(log-debug "Alpha-varying top-levels~n") (define batch-alpha (alpha-vary-ctop batch-gcd)) (define batch-modname (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) -(eprintf "Modularizing into ~a~n" batch-modname) +(log-debug (format "Modularizing into ~a~n" batch-modname)) (define batch-mod (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-alpha)) ;; Output (define batch-final batch-mod) -(eprintf "Writing merged source~n") +(log-debug "Writing merged source~n") (with-output-to-file merged-source-path (lambda () (pretty-print (decompile batch-final))) #:exists 'replace) -(eprintf "Writing merged zo~n") +(log-debug "Writing merged zo~n") (void (with-output-to-file merged-zo-path @@ -120,8 +120,6 @@ Here's the idea: (write-bytes (zo-marshal batch-final))) #:exists 'replace)) -(eprintf "Running merged source~n") -(void (system* (find-executable-path "racket") (path->string merged-source-path))) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index df1d027969..d0b4ddbcba 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -41,12 +41,12 @@ (index<=? stx-pos ordered-stxs)) (prefix-syntax-start new-prefix)) form)) - (eprintf "Total TLS: ~S~n" (length normal-tls)) - (eprintf "Used TLS: ~S~n" normal-tls) - (eprintf "Total lifts: ~S~n" (length lifts)) - (eprintf "Used lifts: ~S~n" lifts) - (eprintf "Total stxs: ~S~n" (length stxs)) - (eprintf "Used stxs: ~S~n" ordered-stxs) + (log-debug (format "Total TLS: ~S~n" (length normal-tls))) + (log-debug (format "Used TLS: ~S~n" normal-tls)) + (log-debug (format "Total lifts: ~S~n" (length lifts))) + (log-debug (format "Used lifts: ~S~n" lifts)) + (log-debug (format "Total stxs: ~S~n" (length stxs))) + (log-debug (format "Used stxs: ~S~n" ordered-stxs)) (make-compilation-top max-let-depth new-prefix diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 33187add17..7163de96d2 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -15,10 +15,10 @@ (define total-tls (length (prefix-toplevels new-prefix))) (define total-stxs (length (prefix-stxs new-prefix))) (define total-lifts (prefix-num-lifts new-prefix)) - (eprintf "max-let-depth ~S to ~S~n" max-let-depth new-max-let-depth) - (eprintf "total toplevels ~S~n" total-tls) - (eprintf "total stxs ~S~n" total-stxs) - (eprintf "num-lifts ~S~n" total-lifts) + (log-debug (format "max-let-depth ~S to ~S~n" max-let-depth new-max-let-depth)) + (log-debug (format "total toplevels ~S~n" total-tls)) + (log-debug (format "total stxs ~S~n" total-stxs)) + (log-debug (format "num-lifts ~S~n" total-lifts)) (make-compilation-top new-max-let-depth new-prefix (make-splice (gen-new-forms new-prefix)))] @@ -60,7 +60,7 @@ [(struct module-variable (modidx sym pos phase)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) - (eprintf "Rewriting ~a of ~S~n" pos (mpi->path* modidx)) + (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) (+ (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx (lambda () (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) @@ -81,7 +81,7 @@ (cond ; Primitive module like #%paramz [(symbol? rw) - (eprintf "~S from ~S~n" sym rw) + (log-debug (format "~S from ~S~n" sym rw)) (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))] @@ -124,20 +124,20 @@ (length mod-toplevels)) (error 'merge-module "Not remapping everything: ~S ~S~n" mod-toplevels toplevel-remap)) - (eprintf "[~S] Incrementing toplevels by ~a~n" + (log-debug (format "[~S] Incrementing toplevels by ~a~n" name - toplevel-offset) - (eprintf "[~S] Incrementing lifts by ~a~n" + toplevel-offset)) + (log-debug (format "[~S] Incrementing lifts by ~a~n" name - lift-offset) - (eprintf "[~S] Filtered mod-vars from ~a to ~a~n" + lift-offset)) + (log-debug (format "[~S] Filtered mod-vars from ~a to ~a~n" name (length mod-toplevels) - (length new-mod-toplevels)) + (length new-mod-toplevels))) (values (max max-let-depth mod-max-let-depth) (merge-prefix top-prefix new-mod-prefix) (lambda (top-prefix) - (eprintf "[~S] Updating top-levels\n" name) + (log-debug (format "[~S] Updating top-levels\n" name)) (define top-lift-start (prefix-lift-start top-prefix)) (define mod-lift-start (prefix-lift-start mod-prefix)) (define total-lifts (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index f6878c2c0d..54507f2365 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -57,7 +57,7 @@ (current-directory))) (define-values (modvar-rewrite lang-info ctop) (begin - (fprintf (current-error-port) "Load ~S @ ~S~n" pth phase) + (log-debug (format "Load ~S @ ~S~n" pth phase)) (nodep/dir (parameterize ([current-load-relative-directory base-directory]) (path->comp-top @@ -98,7 +98,7 @@ (when (symbol? tl) (hash-set! provide-ht (intern tl) i))) (lambda (sym pos) - (eprintf "Looking up ~S@~a~n" sym pos) + (log-debug (format "Looking up ~S@~a~n" sym pos)) (hash-ref provide-ht (intern sym) (lambda () (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))) @@ -114,15 +114,15 @@ [tl (void)]) (prefix-toplevels new-prefix)) - (eprintf "[~S] module-variables: ~S~n" name (length (filter module-variable? (prefix-toplevels new-prefix)))) + (log-debug (format "[~S] module-variables: ~S~n" name (length (filter module-variable? (prefix-toplevels new-prefix))))) (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides)) lang-info (append (requires->modlist requires phase) (if (and phase (zero? phase)) - (begin (eprintf "[~S] lang-info : ~S~n" name lang-info) ; XXX Seems to always be #f now + (begin (log-debug (format "[~S] lang-info : ~S~n" name lang-info)) ; XXX Seems to always be #f now (list (make-mod name srcname self-modidx new-prefix provides requires body empty unexported max-let-depth dummy lang-info internal-context))) - (begin (eprintf "[~S] Dropping module @ ~S~n" name phase) + (begin (log-debug (format "[~S] Dropping module @ ~S~n" name phase)) empty))))] [else (error 'nodep-module "huh?: ~e" mod-form)])) From 7aac10e9380866070c976fca006a993b4da92583 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 27 Sep 2010 15:58:54 -0600 Subject: [PATCH 192/466] offset calculation fix original commit: d84b78daab089923de0fc6a9f0e86e1fc838278f --- collects/compiler/demodularizer/batch.rkt | 3 +- .../compiler/demodularizer/gc-toplevels.rkt | 9 ++-- collects/compiler/demodularizer/merge.rkt | 10 ++-- .../demodularizer/update-toplevels.rkt | 6 +-- collects/compiler/demodularizer/util.rkt | 50 ++++++++++++++----- collects/compiler/zo-marshal.rkt | 7 +-- 6 files changed, 58 insertions(+), 27 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 1c685d67ba..001fb30d53 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -90,7 +90,8 @@ Here's the idea: (log-debug "GC-ing top-levels~n") (define batch-gcd - (gc-toplevels batch-merge)) + batch-merge + #;(gc-toplevels batch-merge)) (log-debug "Alpha-varying top-levels~n") (define batch-alpha diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index d0b4ddbcba..a016720caa 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -134,8 +134,9 @@ (void)] [(and v (not (? form?))) (void)])) - (define build-graph!** (build-form-memo build-graph!* #:void? #t)) - (define (build-graph! lhs form) (build-graph!** form lhs)) + (define-values (first-build-graph!** build-graph!**) + (build-form-memo build-graph!* #:void? #t)) + (define (build-graph! lhs form) (first-build-graph!** form lhs)) build-graph!) (define (graph-dfs g start-node) @@ -267,9 +268,9 @@ [(and v (not (? form?))) v] )) - (define update + (define-values (first-update update) (build-form-memo inner-update)) - update) + first-update) (provide/contract [gc-toplevels (compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 7163de96d2..a6d944d722 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -61,10 +61,10 @@ (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) - (+ (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx + ((hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx (lambda () (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) - (provide->toplevel sym pos))])])) + (provide->toplevel sym pos))])])) (define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) (define-values @@ -76,6 +76,7 @@ (match tl [(and mv (struct module-variable (modidx sym pos phase))) (define rw (get-modvar-rewrite modidx)) + ; XXX We probably don't need to deal with #f phase (unless (or (not phase) (zero? phase)) (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) (cond @@ -99,6 +100,7 @@ (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))]))) + ; XXX This would be more efficient as a vector (values (reverse new-toplevels) (reverse remap))) @@ -119,7 +121,9 @@ (define new-mod-prefix (struct-copy prefix mod-prefix [toplevels new-mod-toplevels])) - (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx toplevel-offset) + (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda (n) + (list-ref toplevel-remap n))) (unless (= (length toplevel-remap) (length mod-toplevels)) (error 'merge-module "Not remapping everything: ~S ~S~n" diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 701b4475d8..c6d1f4d9c6 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -1,5 +1,5 @@ #lang racket -(require compiler/zo-parse +(require compiler/zo-structs "util.rkt") (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) @@ -84,9 +84,9 @@ [(and f (not (? form?))) f] )) - (define update + (define-values (first-update update) (build-form-memo inner-update)) - update) + first-update) (provide/contract [update-toplevels diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 7f8c653049..1334e2911b 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -12,23 +12,46 @@ (define (eprintf . args) (apply fprintf (current-error-port) args)) +(struct nothing ()) + +(define-syntax-rule (eprintf* . args) (void)) + (define (build-form-memo inner-update #:void? [void? #f]) (define memo (make-hasheq)) (define (update form . args) - (cond - [(hash-ref memo form #f) - => (λ (x) x)] - [else - (let () - (define ph (make-placeholder #f)) - (hash-set! memo form ph) - (define nv (apply inner-update form args)) - (placeholder-set! ph nv) - nv)])) + (eprintf* "Updating on ~a\n" form) + (define fin + (cond + [(hash-ref memo form #f) + => (λ (x) + (eprintf* "Found in memo table\n") + x)] + [else + (eprintf* "Not in memo table\n") + (let () + (define ph (make-placeholder (nothing))) + (hash-set! memo form ph) + (define nv (nothing)) + (dynamic-wind void + (λ () + (set! nv (apply inner-update form args))) + (λ () + (if (nothing? nv) + (eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form) + (begin + (placeholder-set! ph nv) + (hash-set! memo form nv))))) + nv)])) + (eprintf* "Updating on ~a ---->\n ~a\n" form fin) + fin) (define (first-update form . args) + (eprintf* "Top level update on ~a\n" form) (define final (apply update form args)) - (make-reader-graph final)) - first-update) + (eprintf* "Top level update on ~a ---->\n ~a\n" form final) + (define fin (make-reader-graph final)) + (eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin) + fin) + (values first-update update)) (define lang-info/c (or/c #f (vector/c module-path? symbol? any/c))) @@ -51,6 +74,7 @@ (((unconstrained-domain-> any/c)) (#:void? boolean?) . ->* . - (unconstrained-domain-> any/c))] + (values (unconstrained-domain-> any/c) + (unconstrained-domain-> any/c)))] [lang-info/c contract?] [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) \ No newline at end of file diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index afd0a0b084..666763ba8b 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -481,8 +481,8 @@ (define-syntax with-type-trace (syntax-rules () [(_ v body ...) - (begin body ...) - #;(with-continuation-mark 'zo (typeof v) + #;(begin body ...) + (with-continuation-mark 'zo (typeof v) (begin0 (begin body ...) (void)))])) (define (out-anything v out) @@ -860,7 +860,8 @@ (out-byte CPT_ESCAPE out) (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) - (out-bytes bstr out)]))))) + (out-bytes bstr out)] + [else (error 'out-anything "~s" (current-type-trace))]))))) (define-struct module-decl (content)) From 6b8a9b086101435588bb97267715d7eddd73224b Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 7 Oct 2010 13:24:25 -0600 Subject: [PATCH 193/466] Avoiding cycles in everything but closures original commit: 7bffbc31a24c8c22c77f5b62a72228551903e9e3 --- collects/compiler/demodularizer/batch.rkt | 8 ++++ collects/compiler/zo-marshal.rkt | 45 ++++++++++++++--------- collects/compiler/zo-parse.rkt | 2 + 3 files changed, 37 insertions(+), 18 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 001fb30d53..99ad2e5e5c 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -76,6 +76,7 @@ Here's the idea: (define merged-source-path (path-add-suffix file-to-batch #".merged.rkt")) +(define merged-struct-path (path-add-suffix file-to-batch #".mergeds.rkt")) (define-values (merged-source-base merged-source-name _1) (split-path merged-source-path)) (define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) @@ -113,6 +114,13 @@ Here's the idea: (pretty-print (decompile batch-final))) #:exists 'replace) +(log-debug "Writing merged struct~n") +(with-output-to-file + merged-struct-path + (lambda () + (pretty-write batch-final)) + #:exists 'replace) + (log-debug "Writing merged zo~n") (void (with-output-to-file diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 666763ba8b..78a5af08e7 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -68,20 +68,22 @@ (out-compilation-top (λ (v #:error? [error? #f]) - (cond - [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] - [(closure? v) - (let ([pos (share! v)]) - (if (encountered? v) - pos - (encounter! v)))] - [error? ; If we would error if this were not present, then we must share it - (encounter! v) - (share! v)] - [(encountered? v) - (share! v)] - [else - (encounter! v)])) + (cond + [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] + [(closure? v) + (let ([pos (share! v)]) + (if (encountered? v) + pos + (encounter! v)))] + [(member v (rest (continuation-mark-set->list (current-continuation-marks) 'cycle))) + #f] + [error? ; If we would error if this were not present, then we must share it + (encounter! v) + (share! v)] + [(encountered? v) + (share! v)] + [else + (encounter! v)])) (λ (v) (unencounter! v)) (open-output-nowhere)) @@ -455,7 +457,7 @@ (define (shareable? v) (define never-share-this? - (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? )) + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?)) (define always-share-this? (or-pred? v closure?)) (or always-share-this? @@ -481,11 +483,18 @@ (define-syntax with-type-trace (syntax-rules () [(_ v body ...) - #;(begin body ...) - (with-continuation-mark 'zo (typeof v) + (begin body ...) + #;(with-continuation-mark 'zo (typeof v) + (begin0 (begin body ...) (void)))])) + +(define-syntax with-cycle-check + (syntax-rules () + [(_ v body ...) + (with-continuation-mark 'cycle v (begin0 (begin body ...) (void)))])) (define (out-anything v out) + (with-cycle-check v (with-type-trace v (out-shared v out @@ -861,7 +870,7 @@ (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) (out-bytes bstr out)] - [else (error 'out-anything "~s" (current-type-trace))]))))) + [else (error 'out-anything "~s" (current-type-trace))])))))) (define-struct module-decl (content)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 000c4efc35..04ff19f019 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1046,6 +1046,8 @@ (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + #;(for ([(i v) (in-dict (cport-symtab cp))]) + (printf "~a = ~a\n" i (placeholder-get v)) ) (set-cport-pos! cp shared-size) (make-reader-graph (read-marshalled 'compilation-top-type cp)))) From 7e97041b8daaf47fb8cf8fdbe52035331554210f Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 13 Oct 2010 12:39:35 -0600 Subject: [PATCH 194/466] debugging original commit: 77c46d07eed7742d6bd525e7180866dbbe15217d --- collects/compiler/zo-marshal.rkt | 3 ++ collects/tests/compiler/zo-exs.rkt | 44 ++++++++++++++++++++++++------ 2 files changed, 38 insertions(+), 9 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 78a5af08e7..445128e074 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -95,6 +95,9 @@ (define-values (symbol-table shared-obj-pos) (create-symbol-table)) + (for ([(i v) (in-dict symbol-table)]) + (printf "~a: ~a\n" i v)) + ; vector output-port -> (listof number) number ; writes symbol-table to outp ; returns the file positions of each value in the symbol table and the end of the symbol table diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 34ca2e4c2e..51b4e8dd9a 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -19,17 +19,17 @@ (test - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) ; XXX This should work, but closures have a field that is gensym'ed - #;(roundtrip + + (roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] - [x (indirect - (closure + [x (application (closure (lam 'name empty 0 @@ -39,7 +39,33 @@ empty 0 ph) - 'name))]) + 'name) empty)]) + (placeholder-set! ph x) + (let ([c (make-reader-graph x)]) + (closure (lam 'name2 + empty + 0 + empty + #f + #() + empty + 0 + (seq (list c c))) 'name2))))) + #;(roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (let* ([ph (make-placeholder #f)] + [x (closure + (lam 'name + empty + 0 + empty + #f + #() + empty + 0 + ph) + 'name)]) (placeholder-set! ph x) (make-reader-graph x)))) @@ -76,24 +102,24 @@ (toplevel 0 0 #f #f) #(racket/language-info get-info #f) #t))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (cons #hash() #hash()))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) From b8122efb82cc471de1652454962e4b758f7ec503 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 26 Oct 2010 15:39:39 -0600 Subject: [PATCH 195/466] using hasheq in zo-marshal original commit: 43e151f340abde95f4825a2f6409b67e048a6aec --- collects/compiler/zo-marshal.rkt | 64 ++++++++++++++++++++++++++------ 1 file changed, 53 insertions(+), 11 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 445128e074..cbd2572bbe 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -44,8 +44,8 @@ ; calculates what values show up in the compilation top more than once ; closures are always included even if they only show up once (define (create-symbol-table) - (define encountered (make-hash)) - (define shared (make-hash)) + (define encountered (make-hasheq)) + (define shared (make-hasheq)) (define (encountered? v) ((hash-ref encountered v 0) . > . 0)) (define (encounter! v) @@ -66,11 +66,17 @@ (hash-set! shared v pos) pos))) - (out-compilation-top - (λ (v #:error? [error? #f]) + (define (do-pass) + (out-compilation-top + (λ (v #:error? [error? #f]) (cond - [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] + #;[(contains-a-cycle? v) + #f] + [(hash? v) + (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] [(closure? v) + #;(when (cyclic-closure? v) + (record-contains-a-cycle!)) (let ([pos (share! v)]) (if (encountered? v) pos @@ -84,18 +90,54 @@ (share! v)] [else (encounter! v)])) - (λ (v) - (unencounter! v)) - (open-output-nowhere)) + (λ (v) + (unencounter! v)) + (open-output-nowhere))) + + ;(do-pass) + ;(hash-remove-all! shared) + ;(hash-remove-all! encountered) + (do-pass) (define symbol-table (make-vector (hash-count shared) (not-ready))) - (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) - (values symbol-table shared-obj-pos)) + + ; Closures go first in the symbol table + ; to avoid... + ; Reading symtab#1 where it references symtab #2 + ; Symtab#2 is a closure + ; Symtab#2 references symtab#1 + ; Thus, there is a "cycle" reading symtab#1 + ; and cycles are only allowed in closures. + ; XXX Can we get the following? + ; [1 |-> (closure ... #2 ...)] + ; [2 |-> (closure ... #1 ...)] + ; JM: We can fabricate one, definitely, but I don't think + ; we could possibly parse it. And I don't think the + ; compiler would ever make one. + (define sorted-shared-objs + (sort (hash-keys shared) + (λ (x y) + ; Move closures to the left + (closure? x)))) + (define relabeling (make-vector (hash-count shared) #f)) + (for ([obj sorted-shared-objs] + [actual-pos (in-naturals)]) + (define pos (hash-ref shared obj)) + (vector-set! relabeling (sub1 pos) (add1 actual-pos)) + (vector-set! symbol-table actual-pos obj)) + + (define (relabeled-shared-obj-pos v #:error? [error? #f]) + (define old-pos + (shared-obj-pos v #:error? error?)) + (and old-pos + (vector-ref relabeling (sub1 old-pos)))) + + (values symbol-table relabeled-shared-obj-pos)) (define-values (symbol-table shared-obj-pos) (create-symbol-table)) - (for ([(i v) (in-dict symbol-table)]) + #;(for ([(i v) (in-dict symbol-table)]) (printf "~a: ~a\n" i v)) ; vector output-port -> (listof number) number From 8392dd8fa4d7dbb87bb169f92290ccf383179b0e Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 26 Oct 2010 15:41:36 -0600 Subject: [PATCH 196/466] fixing logging and running code in zo-exs original commit: 0688c1859305c60441d97dc4d2b43cf9e5550802 --- collects/compiler/demodularizer/batch.rkt | 36 +++++++++++------------ collects/compiler/demodularizer/merge.rkt | 22 +++++++------- collects/compiler/zo-parse.rkt | 8 ++++- collects/tests/compiler/zo-exs.rkt | 10 +++++-- 4 files changed, 43 insertions(+), 33 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 99ad2e5e5c..2553baeaf9 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -46,6 +46,7 @@ Here's the idea: "gc-toplevels.rkt" "alpha.rkt" "module.rkt" + "replace-modidx.rkt" compiler/decompile compiler/zo-marshal racket/set) @@ -65,13 +66,13 @@ Here's the idea: ;; Compile -#;(log-debug "Removing existing zo file~n") +#;(log-debug "Removing existing zo file") #;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) #;(when (file-exists? compiled-zo-path) (delete-file compiled-zo-path)) -(log-debug "Compiling module~n") +(log-debug "Compiling module") (void (system* (find-executable-path "raco") "make" file-to-batch)) @@ -81,52 +82,49 @@ Here's the idea: (define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) ;; Transformations -(log-debug "Removing dependencies~n") +(log-debug "Removing dependencies") (define-values (batch-nodep top-lang-info top-self-modidx) (nodep-file file-to-batch (excluded-modules))) -(log-debug "Merging modules~n") +(log-debug "Merging modules") (define batch-merge (merge-compilation-top batch-nodep)) -(log-debug "GC-ing top-levels~n") +(log-debug "GC-ing top-levels") (define batch-gcd batch-merge #;(gc-toplevels batch-merge)) -(log-debug "Alpha-varying top-levels~n") +(log-debug "Alpha-varying top-levels") (define batch-alpha (alpha-vary-ctop batch-gcd)) +(log-debug "Replacing self-modidx") +(define batch-replace-modidx + (replace-modidx batch-alpha top-self-modidx)) + (define batch-modname (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) -(log-debug (format "Modularizing into ~a~n" batch-modname)) +(log-debug (format "Modularizing into ~a" batch-modname)) (define batch-mod - (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-alpha)) + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) ;; Output (define batch-final batch-mod) -(log-debug "Writing merged source~n") +(log-debug "Writing merged source") (with-output-to-file merged-source-path (lambda () - (pretty-print (decompile batch-final))) + (write batch-final)) #:exists 'replace) -(log-debug "Writing merged struct~n") -(with-output-to-file - merged-struct-path - (lambda () - (pretty-write batch-final)) - #:exists 'replace) - -(log-debug "Writing merged zo~n") +(log-debug "Writing merged zo") (void (with-output-to-file merged-zo-path (lambda () - (write-bytes (zo-marshal batch-final))) + (zo-marshal-to batch-final (current-output-port))) #:exists 'replace)) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index a6d944d722..942305bc93 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -15,10 +15,10 @@ (define total-tls (length (prefix-toplevels new-prefix))) (define total-stxs (length (prefix-stxs new-prefix))) (define total-lifts (prefix-num-lifts new-prefix)) - (log-debug (format "max-let-depth ~S to ~S~n" max-let-depth new-max-let-depth)) - (log-debug (format "total toplevels ~S~n" total-tls)) - (log-debug (format "total stxs ~S~n" total-stxs)) - (log-debug (format "num-lifts ~S~n" total-lifts)) + (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) + (log-debug (format "total toplevels ~S" total-tls)) + (log-debug (format "total stxs ~S" total-stxs)) + (log-debug (format "num-lifts ~S" total-lifts)) (make-compilation-top new-max-let-depth new-prefix (make-splice (gen-new-forms new-prefix)))] @@ -60,7 +60,7 @@ [(struct module-variable (modidx sym pos phase)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) - (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) + (log-debug (format "Rewriting ~a of ~S" pos (mpi->path* modidx))) ((hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx (lambda () (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) @@ -82,7 +82,7 @@ (cond ; Primitive module like #%paramz [(symbol? rw) - (log-debug (format "~S from ~S~n" sym rw)) + (log-debug (format "~S from ~S" sym rw)) (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))] @@ -126,22 +126,22 @@ (list-ref toplevel-remap n))) (unless (= (length toplevel-remap) (length mod-toplevels)) - (error 'merge-module "Not remapping everything: ~S ~S~n" + (error 'merge-module "Not remapping everything: ~S ~S" mod-toplevels toplevel-remap)) - (log-debug (format "[~S] Incrementing toplevels by ~a~n" + (log-debug (format "[~S] Incrementing toplevels by ~a" name toplevel-offset)) - (log-debug (format "[~S] Incrementing lifts by ~a~n" + (log-debug (format "[~S] Incrementing lifts by ~a" name lift-offset)) - (log-debug (format "[~S] Filtered mod-vars from ~a to ~a~n" + (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" name (length mod-toplevels) (length new-mod-toplevels))) (values (max max-let-depth mod-max-let-depth) (merge-prefix top-prefix new-mod-prefix) (lambda (top-prefix) - (log-debug (format "[~S] Updating top-levels\n" name)) + (log-debug (format "[~S] Updating top-levels" name)) (define top-lift-start (prefix-lift-start top-prefix)) (define mod-lift-start (prefix-lift-start mod-prefix)) (define total-lifts (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 04ff19f019..41865df308 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -950,7 +950,12 @@ (make-closure v ; XXX Why call gensym here? - (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure])) + #;(gensym (let ([s (lam-name v)]) (cond [(symbol? s) s] @@ -1046,6 +1051,7 @@ (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + #;(printf "Parsed table:\n") #;(for ([(i v) (in-dict (cport-symtab cp))]) (printf "~a = ~a\n" i (placeholder-get v)) ) (set-cport-pos! cp shared-size) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 51b4e8dd9a..858a557def 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -7,13 +7,19 @@ (parameterize ([read-accept-compiled #t]) (read (open-input-bytes bs)))) +(define (run-compiled-bytes bs [delayed? #t]) + (system "touch test.rkt") + (system "touch compiled/test_rkt.zo") + (system (format "racket ~a -t test.rkt" (if delayed? "" "-d")))) + (define (roundtrip ct) (define bs (zo-marshal ct)) - (with-output-to-file "test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) + (with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) (test #:failure-prefix (format "~S" ct) (test bs (zo-parse (open-input-bytes bs)) => ct - (read-compiled-bytes bs)))) + (run-compiled-bytes bs #t) + (run-compiled-bytes bs #f)))) (define mpi (module-path-index-join #f #f)) From 969c0f4d5848176eedf9517de0c828078c67362f Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 26 Oct 2010 15:45:30 -0600 Subject: [PATCH 197/466] replacing self modidx refs and tests original commit: b2b5875e3ebdf5a1f173c72f4d84707c9a3484d0 --- .../compiler/demodularizer/replace-modidx.rkt | 25 +++++++++ .../compiler/demodularizer/demod-test.rkt | 53 +++++++++++++++++++ .../compiler/demodularizer/tests/kernel-5.rkt | 5 ++ .../compiler/demodularizer/tests/racket-5.rkt | 2 + 4 files changed, 85 insertions(+) create mode 100644 collects/compiler/demodularizer/replace-modidx.rkt create mode 100644 collects/tests/compiler/demodularizer/demod-test.rkt create mode 100644 collects/tests/compiler/demodularizer/tests/kernel-5.rkt create mode 100644 collects/tests/compiler/demodularizer/tests/racket-5.rkt diff --git a/collects/compiler/demodularizer/replace-modidx.rkt b/collects/compiler/demodularizer/replace-modidx.rkt new file mode 100644 index 0000000000..7ad45cbc56 --- /dev/null +++ b/collects/compiler/demodularizer/replace-modidx.rkt @@ -0,0 +1,25 @@ +#lang racket +(require unstable/struct + "util.rkt") +(provide replace-modidx) + +(define (replace-modidx expr self-modidx) + (define (inner-update e) + (match e + [(app prefab-struct-key (and key (not #f))) + (apply make-prefab-struct key + (map update + (struct->list e)))] + [(? module-path-index?) + (define-values (path mpi) (module-path-index-split e)) + (if (not path) + self-modidx + (module-path-index-join path (update mpi)))] + [(cons a b) + (cons (update a) (update b))] + [(? vector?) + (vector-map update e)] + [else e])) + (define-values (first-update update) + (build-form-memo inner-update)) + (first-update expr)) diff --git a/collects/tests/compiler/demodularizer/demod-test.rkt b/collects/tests/compiler/demodularizer/demod-test.rkt new file mode 100644 index 0000000000..ed29ff1f3e --- /dev/null +++ b/collects/tests/compiler/demodularizer/demod-test.rkt @@ -0,0 +1,53 @@ +#lang racket +(require tests/eli-tester + racket/runtime-path) + +(define (capture-output command . args) + (define o (open-output-string)) + (define e (open-output-string)) + (parameterize ([current-input-port (open-input-string "")] + [current-output-port o] + [current-error-port e]) + (apply system* command args)) + (values (get-output-string o) (get-output-string e))) + +(define (test-on-program filename) + ; run modular program, capture output + (define-values (modular-output modular-error) + (capture-output (find-executable-path "racket") filename)) + + ; demodularize + (parameterize ([current-input-port (open-input-string "")]) + (system* (find-executable-path "raco") "demod" filename)) + + (define demod-filename + (path->string + (path-add-suffix filename #".merged.rkt"))) + + ; run whole program + (define-values (whole-output whole-error) + (capture-output (find-executable-path "racket") demod-filename)) + + (display whole-error) + + ; compare output + (test + #:failure-prefix (format "~a stdout" filename) + whole-output => modular-output + #:failure-prefix (format "~a stderr" filename) + whole-error => modular-error)) + +(define-runtime-path tests "tests") + +(define (modular-program? filename) + (and (not (regexp-match #rx"merged" filename)) + (regexp-match #rx"rkt$" filename))) + +(test-on-program "/Users/blake/Development/plt/collects/tests/compiler/demodularizer/tests/racket-5.rkt") + +#;(test + (for ([i (in-list (directory-list tests))]) + (define ip (build-path tests i)) + (when (modular-program? ip) + (printf "Checking ~a\n" ip) + (test-on-program (path->string ip))))) \ No newline at end of file diff --git a/collects/tests/compiler/demodularizer/tests/kernel-5.rkt b/collects/tests/compiler/demodularizer/tests/kernel-5.rkt new file mode 100644 index 0000000000..2cee709c7f --- /dev/null +++ b/collects/tests/compiler/demodularizer/tests/kernel-5.rkt @@ -0,0 +1,5 @@ +(module kernel-5 '#%kernel + (#%require racket/private/map) + (define-values (id) (λ (x) x)) + (define-values (xs) (list 1 2 3 4 5)) + (map id (map id xs))) \ No newline at end of file diff --git a/collects/tests/compiler/demodularizer/tests/racket-5.rkt b/collects/tests/compiler/demodularizer/tests/racket-5.rkt new file mode 100644 index 0000000000..a48b41da12 --- /dev/null +++ b/collects/tests/compiler/demodularizer/tests/racket-5.rkt @@ -0,0 +1,2 @@ +#lang racket +5 \ No newline at end of file From 345f30f7e5780075ce8e467404de1a252e8ad7b6 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 27 Oct 2010 23:33:19 -0600 Subject: [PATCH 198/466] rolling back some unnecessary changes original commit: a315f79ebddaa7695f08f73ccdf78ae5c858f713 --- collects/compiler/zo-marshal.rkt | 102 ++++++++----------------------- 1 file changed, 24 insertions(+), 78 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index cbd2572bbe..5629f4a917 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -66,80 +66,33 @@ (hash-set! shared v pos) pos))) - (define (do-pass) - (out-compilation-top - (λ (v #:error? [error? #f]) - (cond - #;[(contains-a-cycle? v) - #f] - [(hash? v) - (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] - [(closure? v) - #;(when (cyclic-closure? v) - (record-contains-a-cycle!)) - (let ([pos (share! v)]) - (if (encountered? v) - pos - (encounter! v)))] - [(member v (rest (continuation-mark-set->list (current-continuation-marks) 'cycle))) - #f] - [error? ; If we would error if this were not present, then we must share it - (encounter! v) - (share! v)] - [(encountered? v) - (share! v)] - [else - (encounter! v)])) - (λ (v) - (unencounter! v)) - (open-output-nowhere))) - - ;(do-pass) - ;(hash-remove-all! shared) - ;(hash-remove-all! encountered) - (do-pass) + (out-compilation-top + (λ (v #:error? [error? #f]) + (cond + [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] + [(closure? v) + (let ([pos (share! v)]) + (if (encountered? v) + pos + (encounter! v)))] + [error? ; If we would error if this were not present, then we must share it + (encounter! v) + (share! v)] + [(encountered? v) + (share! v)] + [else + (encounter! v)])) + (λ (v) + (unencounter! v)) + (open-output-nowhere)) (define symbol-table (make-vector (hash-count shared) (not-ready))) - - ; Closures go first in the symbol table - ; to avoid... - ; Reading symtab#1 where it references symtab #2 - ; Symtab#2 is a closure - ; Symtab#2 references symtab#1 - ; Thus, there is a "cycle" reading symtab#1 - ; and cycles are only allowed in closures. - ; XXX Can we get the following? - ; [1 |-> (closure ... #2 ...)] - ; [2 |-> (closure ... #1 ...)] - ; JM: We can fabricate one, definitely, but I don't think - ; we could possibly parse it. And I don't think the - ; compiler would ever make one. - (define sorted-shared-objs - (sort (hash-keys shared) - (λ (x y) - ; Move closures to the left - (closure? x)))) - (define relabeling (make-vector (hash-count shared) #f)) - (for ([obj sorted-shared-objs] - [actual-pos (in-naturals)]) - (define pos (hash-ref shared obj)) - (vector-set! relabeling (sub1 pos) (add1 actual-pos)) - (vector-set! symbol-table actual-pos obj)) - - (define (relabeled-shared-obj-pos v #:error? [error? #f]) - (define old-pos - (shared-obj-pos v #:error? error?)) - (and old-pos - (vector-ref relabeling (sub1 old-pos)))) - - (values symbol-table relabeled-shared-obj-pos)) + (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) + (values symbol-table shared-obj-pos)) (define-values (symbol-table shared-obj-pos) (create-symbol-table)) - #;(for ([(i v) (in-dict symbol-table)]) - (printf "~a: ~a\n" i v)) - ; vector output-port -> (listof number) number ; writes symbol-table to outp ; returns the file positions of each value in the symbol table and the end of the symbol table @@ -528,18 +481,11 @@ (define-syntax with-type-trace (syntax-rules () [(_ v body ...) - (begin body ...) - #;(with-continuation-mark 'zo (typeof v) - (begin0 (begin body ...) (void)))])) - -(define-syntax with-cycle-check - (syntax-rules () - [(_ v body ...) - (with-continuation-mark 'cycle v + #;(begin body ...) + (with-continuation-mark 'zo (typeof v) (begin0 (begin body ...) (void)))])) (define (out-anything v out) - (with-cycle-check v (with-type-trace v (out-shared v out @@ -915,7 +861,7 @@ (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) (out-bytes bstr out)] - [else (error 'out-anything "~s" (current-type-trace))])))))) + [else (error 'out-anything "~s" (current-type-trace))]))))) (define-struct module-decl (content)) From 8ae1cd0c3eb8a25d70948d26fc13f95e7e6e1b16 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 29 Oct 2010 14:22:28 -0600 Subject: [PATCH 199/466] only creating zo file original commit: 783418ce37474b4562ae70dd4c1ca68158ab7f1d --- collects/compiler/demodularizer/batch.rkt | 47 +++++-------------- .../compiler/demodularizer/demod-test.rkt | 8 +--- 2 files changed, 15 insertions(+), 40 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 2553baeaf9..e65df730ac 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -66,67 +66,46 @@ Here's the idea: ;; Compile -#;(log-debug "Removing existing zo file") -#;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) -#;(when (file-exists? compiled-zo-path) - (delete-file compiled-zo-path)) - -(log-debug "Compiling module") +(log-info "Compiling module") (void (system* (find-executable-path "raco") "make" file-to-batch)) -(define merged-source-path (path-add-suffix file-to-batch #".merged.rkt")) -(define merged-struct-path (path-add-suffix file-to-batch #".mergeds.rkt")) -(define-values (merged-source-base merged-source-name _1) (split-path merged-source-path)) -(define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) +(define merged-zo-path (path-add-suffix file-to-batch #"_merged.zo")) ;; Transformations -(log-debug "Removing dependencies") +(log-info "Removing dependencies") (define-values (batch-nodep top-lang-info top-self-modidx) (nodep-file file-to-batch (excluded-modules))) -(log-debug "Merging modules") +(log-info "Merging modules") (define batch-merge (merge-compilation-top batch-nodep)) -(log-debug "GC-ing top-levels") +; Not doing this for now +;(log-info "GC-ing top-levels") (define batch-gcd batch-merge #;(gc-toplevels batch-merge)) -(log-debug "Alpha-varying top-levels") +(log-info "Alpha-varying top-levels") (define batch-alpha (alpha-vary-ctop batch-gcd)) -(log-debug "Replacing self-modidx") +(log-info "Replacing self-modidx") (define batch-replace-modidx (replace-modidx batch-alpha top-self-modidx)) (define batch-modname - (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) -(log-debug (format "Modularizing into ~a" batch-modname)) + (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) +(log-info (format "Modularizing into ~a" batch-modname)) (define batch-mod (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) -;; Output -(define batch-final batch-mod) - -(log-debug "Writing merged source") -(with-output-to-file - merged-source-path - (lambda () - (write batch-final)) - #:exists 'replace) - -(log-debug "Writing merged zo") +(log-info "Writing merged zo") (void (with-output-to-file merged-zo-path (lambda () - (zo-marshal-to batch-final (current-output-port))) - #:exists 'replace)) - - - - + (zo-marshal-to batch-mod (current-output-port))) + #:exists 'replace)) \ No newline at end of file diff --git a/collects/tests/compiler/demodularizer/demod-test.rkt b/collects/tests/compiler/demodularizer/demod-test.rkt index ed29ff1f3e..dec2f03a96 100644 --- a/collects/tests/compiler/demodularizer/demod-test.rkt +++ b/collects/tests/compiler/demodularizer/demod-test.rkt @@ -22,14 +22,12 @@ (define demod-filename (path->string - (path-add-suffix filename #".merged.rkt"))) + (path-add-suffix filename #"_merged.zo"))) ; run whole program (define-values (whole-output whole-error) (capture-output (find-executable-path "racket") demod-filename)) - (display whole-error) - ; compare output (test #:failure-prefix (format "~a stdout" filename) @@ -43,9 +41,7 @@ (and (not (regexp-match #rx"merged" filename)) (regexp-match #rx"rkt$" filename))) -(test-on-program "/Users/blake/Development/plt/collects/tests/compiler/demodularizer/tests/racket-5.rkt") - -#;(test +(test (for ([i (in-list (directory-list tests))]) (define ip (build-path tests i)) (when (modular-program? ip) From aae51fbb872dd4d02cd7be579718ba2f12b22227 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 29 Oct 2010 21:32:31 -0600 Subject: [PATCH 200/466] Repairing tests original commit: ec7157744f870825442f5e3263daf1e53e52a79e --- collects/tests/compiler/zo-exs.rkt | 61 ++++++------------------------ 1 file changed, 11 insertions(+), 50 deletions(-) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 858a557def..3bd665ca04 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -14,50 +14,24 @@ (define (roundtrip ct) (define bs (zo-marshal ct)) - (with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) (test #:failure-prefix (format "~S" ct) (test bs (zo-parse (open-input-bytes bs)) => ct - (run-compiled-bytes bs #t) - (run-compiled-bytes bs #f)))) + (read-compiled-bytes bs) + #;(with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) + #;(run-compiled-bytes bs #t) + #;(run-compiled-bytes bs #f)))) (define mpi (module-path-index-join #f #f)) (test - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - ; XXX This should work, but closures have a field that is gensym'ed (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (let* ([ph (make-placeholder #f)] - [x (application (closure - (lam 'name - empty - 0 - empty - #f - #() - empty - 0 - ph) - 'name) empty)]) - (placeholder-set! ph x) - (let ([c (make-reader-graph x)]) - (closure (lam 'name2 - empty - 0 - empty - #f - #() - empty - 0 - (seq (list c c))) 'name2))))) - #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] @@ -108,39 +82,26 @@ (toplevel 0 0 #f #f) #(racket/language-info get-info #f) #t))) - #;(roundtrip + + (roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (cons #hash() #hash()))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) - #hash())) - - #;(local [(define (hash-test make-hash-placeholder) - (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (local [(define ht-ph (make-placeholder #f)) - (define ht (make-hash-placeholder (list (cons 'g ht-ph))))] - (placeholder-set! ht-ph ht) - (make-reader-graph ht)))))] - (hash-test make-hash-placeholder) - (hash-test make-hasheq-placeholder) - (hash-test make-hasheqv-placeholder))) - - + #hash()))) \ No newline at end of file From e5b1e20529f19d774f5b806cde227499143eead3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 30 Oct 2010 08:31:23 -0600 Subject: [PATCH 201/466] Removing newlines from debug messages original commit: 46e2e7931a0dd01f8dc429f742db1f3fbba539b3 --- collects/compiler/demodularizer/gc-toplevels.rkt | 12 ++++++------ collects/compiler/demodularizer/mpi.rkt | 2 +- collects/compiler/demodularizer/nodep.rkt | 12 ++++++------ 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index a016720caa..79401002d5 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -41,12 +41,12 @@ (index<=? stx-pos ordered-stxs)) (prefix-syntax-start new-prefix)) form)) - (log-debug (format "Total TLS: ~S~n" (length normal-tls))) - (log-debug (format "Used TLS: ~S~n" normal-tls)) - (log-debug (format "Total lifts: ~S~n" (length lifts))) - (log-debug (format "Used lifts: ~S~n" lifts)) - (log-debug (format "Total stxs: ~S~n" (length stxs))) - (log-debug (format "Used stxs: ~S~n" ordered-stxs)) + (log-debug (format "Total TLS: ~S" (length normal-tls))) + (log-debug (format "Used TLS: ~S" normal-tls)) + (log-debug (format "Total lifts: ~S" (length lifts))) + (log-debug (format "Used lifts: ~S" lifts)) + (log-debug (format "Total stxs: ~S" (length stxs))) + (log-debug (format "Used stxs: ~S" ordered-stxs)) (make-compilation-top max-let-depth new-prefix diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index ae86a43832..135bf24ecc 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -22,7 +22,7 @@ (define (mpi->path* mpi) (hash-ref MODULE-PATHS mpi (lambda () - (error 'mpi->path* "Cannot locate cache of path for ~S~n" mpi)))) + (error 'mpi->path* "Cannot locate cache of path for ~S" mpi)))) (provide/contract [current-module-path (parameter/c path-string?)] diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 54507f2365..827c38026f 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -57,7 +57,7 @@ (current-directory))) (define-values (modvar-rewrite lang-info ctop) (begin - (log-debug (format "Load ~S @ ~S~n" pth phase)) + (log-debug (format "Load ~S @ ~S" pth phase)) (nodep/dir (parameterize ([current-load-relative-directory base-directory]) (path->comp-top @@ -98,7 +98,7 @@ (when (symbol? tl) (hash-set! provide-ht (intern tl) i))) (lambda (sym pos) - (log-debug (format "Looking up ~S@~a~n" sym pos)) + (log-debug (format "Looking up ~S@~a" sym pos)) (hash-ref provide-ht (intern sym) (lambda () (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))) @@ -114,15 +114,15 @@ [tl (void)]) (prefix-toplevels new-prefix)) - (log-debug (format "[~S] module-variables: ~S~n" name (length (filter module-variable? (prefix-toplevels new-prefix))))) + (log-debug (format "[~S] module-variables: ~S" name (length (filter module-variable? (prefix-toplevels new-prefix))))) (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides)) lang-info (append (requires->modlist requires phase) (if (and phase (zero? phase)) - (begin (log-debug (format "[~S] lang-info : ~S~n" name lang-info)) ; XXX Seems to always be #f now + (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now (list (make-mod name srcname self-modidx new-prefix provides requires body empty unexported max-let-depth dummy lang-info internal-context))) - (begin (log-debug (format "[~S] Dropping module @ ~S~n" name phase)) + (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] [else (error 'nodep-module "huh?: ~e" mod-form)])) @@ -168,7 +168,7 @@ [(@phase? ct) (extract-modules (@phase-ctop ct))] [else - (error 'extract-modules "Unknown extraction: ~S~n" ct)])) + (error 'extract-modules "Unknown extraction: ~S" ct)])) (provide/contract [struct modvar-rewrite From 5f064063f5f2e4c96f7aa297bcc0def3de9e990c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 30 Oct 2010 08:54:13 -0600 Subject: [PATCH 202/466] Saving time by only reading zos once and saving space by limiting the extent of the hash tables original commit: 255489e0af804f05c8519d040b82a0bbce0f1f8c --- collects/compiler/demodularizer/batch.rkt | 4 +- collects/compiler/demodularizer/merge.rkt | 40 +++++++++--------- collects/compiler/demodularizer/nodep.rkt | 49 ++++++++++++++--------- 3 files changed, 54 insertions(+), 39 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index e65df730ac..8bc8967d43 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -75,12 +75,12 @@ Here's the idea: ;; Transformations (log-info "Removing dependencies") -(define-values (batch-nodep top-lang-info top-self-modidx) +(define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) (nodep-file file-to-batch (excluded-modules))) (log-info "Merging modules") (define batch-merge - (merge-compilation-top batch-nodep)) + (merge-compilation-top get-modvar-rewrite batch-nodep)) ; Not doing this for now ;(log-info "GC-ing top-levels") diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 942305bc93..f25dd63166 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -7,22 +7,24 @@ (define MODULE-TOPLEVEL-OFFSETS (make-hash)) -(define (merge-compilation-top top) - (match top - [(struct compilation-top (max-let-depth prefix form)) - (define-values (new-max-let-depth new-prefix gen-new-forms) - (merge-form max-let-depth prefix form)) - (define total-tls (length (prefix-toplevels new-prefix))) - (define total-stxs (length (prefix-stxs new-prefix))) - (define total-lifts (prefix-num-lifts new-prefix)) - (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) - (log-debug (format "total toplevels ~S" total-tls)) - (log-debug (format "total stxs ~S" total-stxs)) - (log-debug (format "num-lifts ~S" total-lifts)) - (make-compilation-top - new-max-let-depth new-prefix - (make-splice (gen-new-forms new-prefix)))] - [else (error 'merge "unrecognized: ~e" top)])) +(define current-get-modvar-rewrite (make-parameter #f)) +(define (merge-compilation-top get-modvar-rewrite top) + (parameterize ([current-get-modvar-rewrite get-modvar-rewrite]) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (define-values (new-max-let-depth new-prefix gen-new-forms) + (merge-form max-let-depth prefix form)) + (define total-tls (length (prefix-toplevels new-prefix))) + (define total-stxs (length (prefix-stxs new-prefix))) + (define total-lifts (prefix-num-lifts new-prefix)) + (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) + (log-debug (format "total toplevels ~S" total-tls)) + (log-debug (format "total stxs ~S" total-stxs)) + (log-debug (format "num-lifts ~S" total-lifts)) + (make-compilation-top + new-max-let-depth new-prefix + (make-splice (gen-new-forms new-prefix)))] + [else (error 'merge "unrecognized: ~e" top)]))) (define (merge-forms max-let-depth prefix forms) (if (empty? forms) @@ -75,7 +77,7 @@ ([tl (in-list mod-toplevels)]) (match tl [(and mv (struct module-variable (modidx sym pos phase))) - (define rw (get-modvar-rewrite modidx)) + (define rw ((current-get-modvar-rewrite) modidx)) ; XXX We probably don't need to deal with #f phase (unless (or (not phase) (zero? phase)) (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) @@ -166,4 +168,6 @@ (map update body)))])) (provide/contract - [merge-compilation-top (compilation-top? . -> . compilation-top?)]) \ No newline at end of file + [merge-compilation-top (-> get-modvar-rewrite/c + compilation-top? + compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 827c38026f..aaa98503e3 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -6,45 +6,53 @@ (define excluded-modules (make-parameter null)) -(define (nodep-file file-to-batch excluded) - (excluded-modules excluded) - (match (get-nodep-module-code/path file-to-batch 0) - [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) - (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite))])) +(define ZOS (make-parameter #f)) +(define MODULE-IDX-MAP (make-parameter #f)) +(define PHASE*MODULE-CACHE (make-parameter #f)) + +(define (nodep-file file-to-batch excluded) + (define idx-map (make-hash)) + (parameterize ([ZOS (make-hash)] + [MODULE-IDX-MAP idx-map] + [PHASE*MODULE-CACHE (make-hash)]) + (define (get-modvar-rewrite modidx) + (define pth (mpi->path* modidx)) + (hash-ref idx-map pth + (lambda () + (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) + (excluded-modules excluded) + (match (get-nodep-module-code/path file-to-batch 0) + [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) + (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)]))) (define (path->comp-top pth) - (call-with-input-file pth zo-parse)) + (hash-ref! (ZOS) pth + (λ () + (call-with-input-file pth zo-parse)))) (define (excluded? pth) (set-member? (excluded-modules) (path->string pth))) -(define MODULE-IDX-MAP (make-hash)) (define (get-nodep-module-code/index mpi phase) (define pth (mpi->path! mpi)) (cond [(symbol? pth) - (hash-set! MODULE-IDX-MAP pth pth) + (hash-set! (MODULE-IDX-MAP) pth pth) pth] [(excluded? pth) - (hash-set! MODULE-IDX-MAP pth mpi) + (hash-set! (MODULE-IDX-MAP) pth mpi) mpi] [else (get-nodep-module-code/path pth phase)])) -(define (get-modvar-rewrite modidx) - (define pth (mpi->path* modidx)) - (hash-ref MODULE-IDX-MAP pth - (lambda () - (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) (define-struct @phase (phase code)) (define-struct modvar-rewrite (modidx provide->toplevel)) (define-struct module-code (modvar-rewrite lang-info ctop)) (define @phase-ctop (compose module-code-ctop @phase-code)) -(define PHASE*MODULE-CACHE (make-hash)) (define (get-nodep-module-code/path pth phase) (define MODULE-CACHE - (hash-ref! PHASE*MODULE-CACHE phase make-hash)) + (hash-ref! (PHASE*MODULE-CACHE) phase make-hash)) (if (hash-ref MODULE-CACHE pth #f) #f (hash-ref! @@ -67,7 +75,7 @@ pth phase))) (when (and phase (zero? phase)) - (hash-set! MODULE-IDX-MAP pth modvar-rewrite)) + (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite)) (make-@phase phase (make-module-code modvar-rewrite lang-info ctop)))))) @@ -170,9 +178,12 @@ [else (error 'extract-modules "Unknown extraction: ~S" ct)])) +(define get-modvar-rewrite/c + (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))) (provide/contract [struct modvar-rewrite ([modidx module-path-index?] [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] - [get-modvar-rewrite (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))] - [nodep-file (path-string? set? . -> . (values compilation-top? lang-info/c module-path-index?))]) \ No newline at end of file + [get-modvar-rewrite/c contract?] + [nodep-file (-> path-string? set? + (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) \ No newline at end of file From c428f6cafe9a5659ed54d8666e39b2578ae021f5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 30 Oct 2010 09:14:58 -0600 Subject: [PATCH 203/466] Exposing more values to GC by not making them toplevels original commit: 26c7625c7903b4edb74d745ff9737fc7ab1e0021 --- collects/compiler/demodularizer/batch.rkt | 116 +++++++++++---------- collects/compiler/demodularizer/module.rkt | 1 - collects/compiler/demodularizer/mpi.rkt | 9 +- collects/compiler/demodularizer/nodep.rkt | 10 +- 4 files changed, 69 insertions(+), 67 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 8bc8967d43..97ec868b12 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -40,6 +40,7 @@ Here's the idea: (require racket/pretty racket/system + "mpi.rkt" "util.rkt" "nodep.rkt" "merge.rkt" @@ -51,61 +52,62 @@ Here's the idea: compiler/zo-marshal racket/set) -(define excluded-modules (make-parameter (set))) -(define file-to-batch - (command-line #:program "batch" - #:multi - [("-e" "--exclude-modules") mod - "Exclude a module from being batched" - (excluded-modules (set-add (excluded-modules) mod))] - #:args (filename) filename)) +(define (main file-to-batch) + (define-values (base name dir?) (split-path file-to-batch)) + (when (or (eq? base #f) dir?) + (error 'batch "Cannot run on directory")) + + ;; Compile + + (log-info "Compiling module") + (void (system* (find-executable-path "raco") "make" file-to-batch)) + + (define merged-zo-path (path-add-suffix file-to-batch #"_merged.zo")) + + ;; Transformations + (define path-cache (make-hash)) + + (log-info "Removing dependencies") + (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) + (parameterize ([MODULE-PATHS path-cache]) + (nodep-file file-to-batch))) + + (log-info "Merging modules") + (define batch-merge + (parameterize ([MODULE-PATHS path-cache]) + (merge-compilation-top get-modvar-rewrite batch-nodep))) + + ; Not doing this for now + ;(log-info "GC-ing top-levels") + (define batch-gcd + batch-merge + #;(gc-toplevels batch-merge)) + + (log-info "Alpha-varying top-levels") + (define batch-alpha + (alpha-vary-ctop batch-gcd)) + + (log-info "Replacing self-modidx") + (define batch-replace-modidx + (replace-modidx batch-alpha top-self-modidx)) + + (define batch-modname + (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) + (log-info (format "Modularizing into ~a" batch-modname)) + (define batch-mod + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) + + (log-info "Writing merged zo") + (void + (with-output-to-file + merged-zo-path + (lambda () + (zo-marshal-to batch-mod (current-output-port))) + #:exists 'replace))) -(define-values (base name dir?) (split-path file-to-batch)) -(when (or (eq? base #f) dir?) - (error 'batch "Cannot run on directory")) - - -;; Compile - -(log-info "Compiling module") -(void (system* (find-executable-path "raco") "make" file-to-batch)) - - -(define merged-zo-path (path-add-suffix file-to-batch #"_merged.zo")) - -;; Transformations -(log-info "Removing dependencies") -(define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) - (nodep-file file-to-batch (excluded-modules))) - -(log-info "Merging modules") -(define batch-merge - (merge-compilation-top get-modvar-rewrite batch-nodep)) - -; Not doing this for now -;(log-info "GC-ing top-levels") -(define batch-gcd - batch-merge - #;(gc-toplevels batch-merge)) - -(log-info "Alpha-varying top-levels") -(define batch-alpha - (alpha-vary-ctop batch-gcd)) - -(log-info "Replacing self-modidx") -(define batch-replace-modidx - (replace-modidx batch-alpha top-self-modidx)) - -(define batch-modname - (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) -(log-info (format "Modularizing into ~a" batch-modname)) -(define batch-mod - (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) - -(log-info "Writing merged zo") -(void - (with-output-to-file - merged-zo-path - (lambda () - (zo-marshal-to batch-mod (current-output-port))) - #:exists 'replace)) \ No newline at end of file +(command-line #:program "batch" + #:multi + [("-e" "--exclude-modules") mod + "Exclude a module from being batched" + (current-excluded-modules (set-add (current-excluded-modules) mod))] + #:args (filename) (main filename)) \ No newline at end of file diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 74d7ccd77b..faa47c49e7 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -7,7 +7,6 @@ s (module-path-index-join `(quote ,s) #f))) - (define (wrap-in-kernel-module name srcname lang-info self-modidx top) (match top [(struct compilation-top (max-let-depth prefix form)) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index 135bf24ecc..3c86837115 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -1,4 +1,4 @@ -#lang scheme +#lang racket (require syntax/modresolve) (define current-module-path (make-parameter #f)) @@ -9,10 +9,10 @@ [else (mpi->path! modidx)])) -(define MODULE-PATHS (make-hash)) +(define MODULE-PATHS (make-parameter #f)) (define (mpi->path! mpi) (hash-ref! - MODULE-PATHS mpi + (MODULE-PATHS) mpi (lambda () (define _pth (resolve-module-path-index mpi (current-module-path))) @@ -20,11 +20,12 @@ (simplify-path _pth #t) _pth)))) (define (mpi->path* mpi) - (hash-ref MODULE-PATHS mpi + (hash-ref (MODULE-PATHS) mpi (lambda () (error 'mpi->path* "Cannot locate cache of path for ~S" mpi)))) (provide/contract + [MODULE-PATHS (parameter/c (or/c false/c hash?))] [current-module-path (parameter/c path-string?)] [mpi->path! (module-path-index? . -> . (or/c symbol? path?))] [mpi->path* (module-path-index? . -> . (or/c symbol? path?))]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index aaa98503e3..0d8c01642d 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -4,13 +4,13 @@ "mpi.rkt" racket/set) -(define excluded-modules (make-parameter null)) +(define current-excluded-modules (make-parameter (set))) (define ZOS (make-parameter #f)) (define MODULE-IDX-MAP (make-parameter #f)) (define PHASE*MODULE-CACHE (make-parameter #f)) -(define (nodep-file file-to-batch excluded) +(define (nodep-file file-to-batch) (define idx-map (make-hash)) (parameterize ([ZOS (make-hash)] [MODULE-IDX-MAP idx-map] @@ -20,7 +20,6 @@ (hash-ref idx-map pth (lambda () (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) - (excluded-modules excluded) (match (get-nodep-module-code/path file-to-batch 0) [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)]))) @@ -31,7 +30,7 @@ (call-with-input-file pth zo-parse)))) (define (excluded? pth) - (set-member? (excluded-modules) (path->string pth))) + (set-member? (current-excluded-modules) (path->string pth))) (define (get-nodep-module-code/index mpi phase) (define pth (mpi->path! mpi)) @@ -185,5 +184,6 @@ ([modidx module-path-index?] [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] [get-modvar-rewrite/c contract?] - [nodep-file (-> path-string? set? + [current-excluded-modules (parameter/c set?)] + [nodep-file (-> path-string? (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) \ No newline at end of file From 74c7025e6e4071e97b1879ae9b71a67153688708 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Sat, 30 Oct 2010 12:31:00 -0600 Subject: [PATCH 204/466] scrbl file and longer command name original commit: 199a63772ad1a9d89bc091da4244902ae16dbd9b --- collects/compiler/commands/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 41b92c0eae..d97e168309 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -8,4 +8,4 @@ ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f) - ("demod" compiler/demodularizer/batch "produce a whole program from a single module" #f))) + ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f))) From 37f822ccb258ed2a8f7eb3504462cfc5f7856c5b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 11 Nov 2010 14:21:04 -0700 Subject: [PATCH 205/466] restore gen-id gensym so that decompiler works original commit: 0a8e5e604ed6ae81391eb05cba992fa9caaba784 --- collects/compiler/zo-parse.rkt | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 41865df308..a4e11f586b 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -949,13 +949,7 @@ (let ([v (read-compact cp)]) (make-closure v - ; XXX Why call gensym here? - (let ([s (lam-name v)]) - (cond - [(symbol? s) s] - [(vector? s) (vector-ref s 0)] - [else 'closure])) - #;(gensym + (gensym (let ([s (lam-name v)]) (cond [(symbol? s) s] From 00134af67b8b0a2329629979e32ce2c5b9c5c2cc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Nov 2010 22:33:37 -0500 Subject: [PATCH 206/466] Removing test because we reintroduced gensym original commit: b686cc84a9e9606658e0e5f0773d402f2bce8854 --- collects/tests/compiler/zo-exs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 3bd665ca04..2abdaab4ff 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -31,7 +31,7 @@ (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] From a3b9b386fe142002db3f6c848dc8a955b9c813a5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 9 Feb 2011 21:13:06 -0500 Subject: [PATCH 207/466] Use proper raco command name in make and pack. Fixes PR 11719. original commit: 0f14c6aa6739b4cfd51d46ec2a49627769738394 --- collects/compiler/commands/make.rkt | 6 ++++-- collects/compiler/commands/pack.rkt | 4 +++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 03dd574409..74f2b85ae7 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -16,6 +16,8 @@ (define assume-primitives (make-parameter #t)) (define worker-count (make-parameter 1)) +(define mzc-symbol (string->symbol (short-program+command-name))) + (define source-files (command-line #:program (short-program+command-name) @@ -67,9 +69,9 @@ (printf " making ~s\n" (path->string p))))]) (for ([file source-files]) (unless (file-exists? file) - (error 'mzc "file does not exist: ~a" file)) + (error mzc-symbol "file does not exist: ~a" file)) (set! did-one? #f) - (let ([name (extract-base-filename/ss file 'mzc)]) + (let ([name (extract-base-filename/ss file mzc-symbol)]) (when (verbose) (printf "\"~a\":\n" file)) (parameterize ([compile-context-preservation-enabled diff --git a/collects/compiler/commands/pack.rkt b/collects/compiler/commands/pack.rkt index 8a2fa32a50..db68d62889 100644 --- a/collects/compiler/commands/pack.rkt +++ b/collects/compiler/commands/pack.rkt @@ -19,6 +19,8 @@ (define plt-setup-collections (make-parameter null)) (define plt-include-compiled (make-parameter #f)) +(define mzc-symbol (string->symbol (short-program+command-name))) + (define-values (plt-output source-files) (command-line #:program (short-program+command-name) @@ -53,7 +55,7 @@ (begin (for ([fd source-files]) (unless (relative-path? fd) - (error 'mzc + (error mzc-symbol "file/directory is not relative to the current directory: \"~a\"" fd))) (pack-plt plt-output From 9f2fba9625f9695ad46841ea41688139809c06ae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 Apr 2011 14:42:57 -0600 Subject: [PATCH 208/466] safe-for-space repairs for functions with rest args original commit: 0754ad01148f3de83b4ce97102d2d0859d56a370 --- collects/compiler/decompile.rkt | 1 + collects/compiler/zo-marshal.rkt | 2 ++ collects/compiler/zo-parse.rkt | 2 ++ collects/compiler/zo-structs.rkt | 3 ++- 4 files changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 4af6bb5d08..0c9c7049b3 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -307,6 +307,7 @@ ,@(if (and name (not (null? name))) `(',name) null) + ,@(if (null? flags) null `('(flags: ,@flags))) ,@(if (null? captures) null `('(captures: ,@(map (lambda (c t) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 659d5da608..d670f06eea 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -257,6 +257,7 @@ (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) (define CLOS_PRESERVES_MARKS 4) +(define CLOS_NEED_REST_CLEAR 8) (define CLOS_IS_METHOD 16) (define CLOS_SINGLE_RESULT 32) @@ -1006,6 +1007,7 @@ (+ (if rest? CLOS_HAS_REST 0) (if any-refs? CLOS_HAS_REF_ARGS 0) (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) + (if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0) (if (memq 'is-method flags) CLOS_IS_METHOD 0) (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) num-all-params diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index d14a296e28..2290bc30bc 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -81,6 +81,7 @@ (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) (define CLOS_PRESERVES_MARKS 4) + (define CLOS_NEED_REST_CLEAR 8) (define CLOS_IS_METHOD 16) (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) @@ -118,6 +119,7 @@ (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) + (if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args)) (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) (if (and rest? (num-params . > . 0)) (sub1 num-params) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index d3933aa349..b9919e4ff3 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -131,7 +131,8 @@ [internal-context (or/c #f #t stx?)])) (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] - [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))] + [flags (listof (or/c 'preserves-marks 'is-method 'single-result + 'only-rest-arg-not-used 'sfs-clear-rest-args))] [num-params exact-nonnegative-integer?] [param-types (listof (or/c 'val 'ref 'flonum))] [rest? boolean?] From 1955c935ffbae66de0e8e38c18e78df624182e4d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 May 2011 20:41:59 -0600 Subject: [PATCH 209/466] break link to namespaces from from closures over top-/module-level vars - the `lam' structure from `compiler/zo-struct' changed to include a `toplevel-map' field This change helps solve a finalization problem in `racket/draw', which in turn sigificantly reduces the peak memory use of `raco setup' during the doc-building phase (because some documents load `racket/draw' to render images, and multiple copies of `racket/draw' were retained before finalization was fixed). The change is an extreme way to solve a specific finalization problem, but it's a kind of space-safety improvement; space safety almost never matters, but when it does, then working around a lack of space safety is practically impossible. In this case, it's not clear how to otherwise solve the `racket/draw' finalization problem. The improvement doesn't change the representation of closures, but it requires special cooperation with the GC. All closures in a module continue to share the same array of globals (plus syntax objects); that is, instead of completely flat closures, Racket uses a two-level environment where top-/module-level variables are grouped together. The code half of a closure now records which top-/module-level variables the body code actually uses, and the mark phase of GC consults this information to retain only parts of the top-/module-level environment frame that are actually used by some closure (or all of the frame if it is accessible through some other route). In other words, the GC supports a kind of "dependent reference" to an array that is indexed by positions into the array --- except that the code is more in the "Racket" directory instead of the "GC" directory, since it's so specific to the closure representation. original commit: 2ada6d0e89a763f3b8523a87e580b1ffb25430eb --- collects/compiler/decompile.rkt | 74 +++++++++++-------- .../compiler/demodularizer/gc-toplevels.rkt | 5 +- .../demodularizer/update-toplevels.rkt | 3 +- collects/compiler/zo-marshal.rkt | 13 +++- collects/compiler/zo-parse.rkt | 19 ++++- collects/compiler/zo-structs.rkt | 4 +- 6 files changed, 81 insertions(+), 37 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 0c9c7049b3..1e84e2cad0 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -2,7 +2,8 @@ (require compiler/zo-parse syntax/modcollapse scheme/port - scheme/match) + scheme/match + racket/set) (provide decompile) @@ -42,6 +43,8 @@ ;; ---------------------------------------- +(define-struct glob-desc (vars num-tls num-stxs num-lifts)) + ;; Main entry: (define (decompile top) (match top @@ -56,30 +59,34 @@ (match a-prefix [(struct prefix (num-lifts toplevels stxs)) (let ([lift-ids (for/list ([i (in-range num-lifts)]) - (gensym 'lift))] + (gensym 'lift))] [stx-ids (map (lambda (i) (gensym 'stx)) stxs)]) - (values (append - (map (lambda (tl) - (match tl - [#f '#%linkage] - [(? symbol?) (string->symbol (format "_~a" tl))] - [(struct global-bucket (name)) - (string->symbol (format "_~a" name))] - [(struct module-variable (modidx sym pos phase)) - (if (and (module-path-index? modidx) - (let-values ([(n b) (module-path-index-split modidx)]) - (and (not n) (not b)))) - (string->symbol (format "_~a" sym)) - (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) - (if (zero? phase) - "" - (format "/~a" phase)))))] - [else (error 'decompile-prefix "bad toplevel: ~e" tl)])) - toplevels) - stx-ids - (if (null? stx-ids) null '(#%stx-array)) - lift-ids) + (values (glob-desc + (append + (map (lambda (tl) + (match tl + [#f '#%linkage] + [(? symbol?) (string->symbol (format "_~a" tl))] + [(struct global-bucket (name)) + (string->symbol (format "_~a" name))] + [(struct module-variable (modidx sym pos phase)) + (if (and (module-path-index? modidx) + (let-values ([(n b) (module-path-index-split modidx)]) + (and (not n) (not b)))) + (string->symbol (format "_~a" sym)) + (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) + (if (zero? phase) + "" + (format "/~a" phase)))))] + [else (error 'decompile-prefix "bad toplevel: ~e" tl)])) + toplevels) + stx-ids + (if (null? stx-ids) null '(#%stx-array)) + lift-ids) + (length toplevels) + (length stxs) + num-lifts) (map (lambda (stx id) `(define ,id ,(if stx `(#%decode-syntax ,(stx-encoded stx)) @@ -117,7 +124,7 @@ `(define-values ,(map (lambda (tl) (match tl [(struct toplevel (depth pos const? mutated?)) - (list-ref/protect globs pos 'def-vals)])) + (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) ids) ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) @@ -154,7 +161,7 @@ (define (extract-id expr) (match expr - [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body)) (extract-name name)] [(struct case-lam (name lams)) (extract-name name)] @@ -179,7 +186,7 @@ (define (decompile-tl expr globs stack closed no-check?) (match expr [(struct toplevel (depth pos const? ready?)) - (let ([id (list-ref/protect globs pos 'toplevel)]) + (let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)]) (if (or no-check? const? ready?) id `(#%checked ,id)))])) @@ -191,7 +198,7 @@ [(struct varref (tl)) `(#%variable-reference ,(decompile-tl tl globs stack closed #t))] [(struct topsyntax (depth pos midpt)) - (list-ref/protect globs (+ midpt pos) 'topsyntax)] + (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] [(struct primval (id)) (hash-ref primitive-table id)] [(struct assign (id rhs undef-ok?)) @@ -291,7 +298,7 @@ (define (decompile-lam expr globs stack closed) (match expr [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] - [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" @@ -315,7 +322,16 @@ `(flonum ,c) c)) captures - closure-types)))) + closure-types) + ,@(if (not tl-map) + '() + (list + (for/list ([pos (in-set tl-map)]) + (list-ref/protect (glob-desc-vars globs) + (if (pos . < . (glob-desc-num-tls globs)) + pos + (+ pos (glob-desc-num-stxs globs) 1)) + 'lam))))))) ,(decompile-expr body globs (append captures (append vars rest-vars)) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index 79401002d5..e03ad418a7 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -74,7 +74,7 @@ (for-each (lambda (f) (build-graph! lhs f)) forms)] [(struct splice (forms)) (for-each (lambda (f) (build-graph! lhs f)) forms)] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) (build-graph! lhs body)] [(and c (struct closure (code gen-id))) (build-graph! lhs code)] @@ -206,8 +206,9 @@ (make-seq (filter identity (map update forms)))] [(struct splice (forms)) (make-splice (filter identity (map update forms)))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) (struct-copy lam l + [toplevel-map #f] ; consevrative [body (update body)])] [(and c (struct closure (code gen-id))) (struct-copy closure c diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index c6d1f4d9c6..e3cdda6110 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -20,8 +20,9 @@ (make-seq (map update forms))] [(struct splice (forms)) (make-splice (map update forms))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) (struct-copy lam l + [toplevel-map #f] ; conservative [body (update body)])] [(and c (struct closure (code gen-id))) (struct-copy closure c diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index d670f06eea..78559d05d5 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -968,7 +968,7 @@ (define (out-lam expr out) (match expr - [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) + [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) (let* ([l (protect-quote body)] [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) (ormap (lambda (t) (memq t '(flonum))) closure-types))] @@ -1001,7 +1001,9 @@ l)] [l (if any-refs? (cons (vector-length closure-map) l) - l)]) + l)] + [tl-map (for/fold ([v 0]) ([i (in-set toplevel-map)]) + (bitwise-ior v (arithmetic-shift 1 i)))]) (out-marshaled unclosed-procedure-type-num (list* (+ (if rest? CLOS_HAS_REST 0) @@ -1012,6 +1014,13 @@ (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) num-all-params max-let-depth + (if (tl-map . < . #x7FFFFFFF) + tl-map + ;; Encode as an even-sized vector of 16-bit integers: + (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) + (for/vector ([i (in-range len)]) + (let ([s (* i 16)]) + (bitwise-bit-field tl-map s (+ s 16)))))) name l) out))])) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 2290bc30bc..7f8770ee44 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -5,7 +5,8 @@ scheme/list unstable/struct compiler/zo-structs - racket/dict) + racket/dict + racket/set) (provide zo-parse) (provide (all-from-out compiler/zo-structs)) @@ -86,7 +87,7 @@ (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) (match v - [`(,flags ,num-params ,max-let-depth ,name ,v . ,rest) + [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) (let*-values ([(closure-size closed-over body) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) @@ -132,6 +133,20 @@ (vector-copy! v2 0 closed-over 0 closure-size) v2)) closure-types + (and tl-map + (let* ([bits (if (exact-integer? tl-map) + tl-map + (for/fold ([i 0]) ([v (in-list tl-map)] + [s (in-naturals)]) + (bitwise-ior i (arithmetic-shift v 16))))] + [len (integer-length bits)]) + (list->set + (let loop ([bit 0]) + (cond + [(bit . >= . len) null] + [(bitwise-bit-set? bits bit) + (cons bit (loop (add1 bit)))] + [else (loop (add1 bit))]))))) max-let-depth body)))])) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index b9919e4ff3..2d0e920177 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -2,7 +2,8 @@ (require mzlib/etc scheme/match scheme/contract - scheme/list) + scheme/list + racket/set) #| Unresolved issues @@ -138,6 +139,7 @@ [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] [closure-types (listof (or/c 'val/ref 'flonum))] + [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))] [max-let-depth exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; `lambda' (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) From 805b8627f32d46ef8143bbeb461c94aecb85a9c7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 May 2011 14:28:51 -0600 Subject: [PATCH 210/466] fix `zo-marshal' for #f toplevel-map in `lam' original commit: 87a4132b407a1ab9b61dc950ff2378b9b6b8d751 --- collects/compiler/zo-marshal.rkt | 20 +++++++++++--------- collects/tests/compiler/zo-exs.rkt | 9 +++++++++ 2 files changed, 20 insertions(+), 9 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 78559d05d5..91380a3e51 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1002,8 +1002,9 @@ [l (if any-refs? (cons (vector-length closure-map) l) l)] - [tl-map (for/fold ([v 0]) ([i (in-set toplevel-map)]) - (bitwise-ior v (arithmetic-shift 1 i)))]) + [tl-map (and toplevel-map + (for/fold ([v 0]) ([i (in-set toplevel-map)]) + (bitwise-ior v (arithmetic-shift 1 i))))]) (out-marshaled unclosed-procedure-type-num (list* (+ (if rest? CLOS_HAS_REST 0) @@ -1014,13 +1015,14 @@ (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) num-all-params max-let-depth - (if (tl-map . < . #x7FFFFFFF) - tl-map - ;; Encode as an even-sized vector of 16-bit integers: - (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) - (for/vector ([i (in-range len)]) - (let ([s (* i 16)]) - (bitwise-bit-field tl-map s (+ s 16)))))) + (and tl-map + (if (tl-map . < . #x7FFFFFFF) + tl-map + ;; Encode as an even-sized vector of 16-bit integers: + (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) + (for/vector ([i (in-range len)]) + (let ([s (* i 16)]) + (bitwise-bit-field tl-map s (+ s 16))))))) name l) out))])) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 2abdaab4ff..c395604236 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -31,6 +31,15 @@ (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) + (roundtrip + (compilation-top 0 + (prefix 1 empty empty) + (list (lam 'proc null 0 null #f #(0) '(val/ref) (set 0) 3 1)))) + (roundtrip + (compilation-top 0 + (prefix 1 empty empty) + (list (lam 'proc null 0 null #f #(0) '(val/ref) #f 3 1)))) + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) From 87373a2e0c3b1dbbeefc9ed9891fbe0e2a865952 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 May 2011 20:52:23 -0600 Subject: [PATCH 211/466] reorgnize datatypes of less common bytecode forms removing a layer of indirection, and setting up for an internal reorganization of the compiler code original commit: e9721058fb50e1dc38c0015ce89ac737d46ba462 --- collects/compiler/zo-marshal.rkt | 326 ++++++++++++++----------------- collects/compiler/zo-parse.rkt | 77 ++++---- 2 files changed, 180 insertions(+), 223 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 91380a3e51..ced39b755c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -149,21 +149,29 @@ ;; ---------------------------------------- (define toplevel-type-num 0) -(define syntax-type-num 3) -(define sequence-type-num 7) -(define unclosed-procedure-type-num 9) -(define let-value-type-num 10) -(define let-void-type-num 11) -(define letrec-type-num 12) -(define wcm-type-num 14) -(define quote-syntax-type-num 15) -(define variable-type-num 24) -(define top-type-num 89) -(define case-lambda-sequence-type-num 99) -(define begin0-sequence-type-num 100) -(define module-type-num 103) -(define prefix-type-num 105) -(define free-id-info-type-num 154) +(define sequence-type-num 6) +(define unclosed-procedure-type-num 8) +(define let-value-type-num 9) +(define let-void-type-num 10) +(define letrec-type-num 11) +(define wcm-type-num 13) +(define quote-syntax-type-num 14) +(define define-values-type-num 15) +(define define-syntaxes-type-num 16) +(define define-for-syntax-type-num 17) +(define set-bang-type-num 18) +(define boxenv-type-num 19) +(define begin0-sequence-type-num 20) +(define splice-sequence-type-num 21) +(define require-form-type-num 22) +(define varref-form-type-num 23) +(define apply-values-type-num 24) +(define case-lambda-sequence-type-num 25) +(define module-type-num 26) +(define variable-type-num 34) +(define top-type-num 99) +(define prefix-type-num 112) +(define free-id-info-type-num 161) (define-syntax define-enum (syntax-rules () @@ -212,21 +220,6 @@ CPT_PREFAB CPT_LET_ONE_UNUSED) -(define-enum - 0 - DEFINE_VALUES_EXPD - DEFINE_SYNTAX_EXPD - SET_EXPD - CASE_LAMBDA_EXPD - BEGIN0_EXPD - BOXENV_EXPD - MODULE_EXPD - REQUIRE_EXPD - DEFINE_FOR_SYNTAX_EXPD - REF_EXPD - APPVALS_EXPD - SPLICE_EXPD) - (define CPT_SMALL_NUMBER_START 36) (define CPT_SMALL_NUMBER_END 60) @@ -271,10 +264,6 @@ #f #f)) -(define-struct case-seq (name lams)) -(define-struct (seq0 seq) ()) - - (define (encode-module-bindings module-bindings) (define encode-nominal-path (match-lambda @@ -440,9 +429,6 @@ (out-byte #xF0 out) (out-bytes (int->bytes n) out)])) -(define (out-syntax key val out) - (out-marshaled syntax-type-num (list* key val) out)) - (define (out-marshaled type-num val out) (if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START)) (out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out) @@ -541,34 +527,34 @@ [(? mod?) (out-module v out)] [(struct def-values (ids rhs)) - (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons (protect-quote rhs) ids)) - out)] + (out-marshaled define-values-type-num + (list->vector (cons (protect-quote rhs) ids)) + out)] [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] + (out-marshaled define-syntaxes-type-num + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct seq0 (forms)) + (out-marshaled define-for-syntax-type-num + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct beg0 (forms)) (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] [(struct seq (forms)) (out-marshaled sequence-type-num (map protect-quote forms) out)] [(struct splice (forms)) - (out-syntax SPLICE_EXPD (make-seq forms) out)] + (out-marshaled splice-sequence-type-num forms out)] [(struct req (reqs dummy)) (error "cannot handle top-level `require', yet") - (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] + (out-marshaled require-form-type-num (cons dummy reqs) out)] [(struct toplevel (depth pos const? ready?)) (out-marshaled toplevel-type-num (cons @@ -589,9 +575,9 @@ (out-byte CPT_REFERENCE out) (out-number id out)] [(struct assign (id rhs undef-ok?)) - (out-syntax SET_EXPD - (cons undef-ok? (cons id rhs)) - out)] + (out-marshaled set-bang-type-num + (cons undef-ok? (cons id rhs)) + out)] [(struct localref (unbox? offset clear? other-clears? flonum?)) (if (and (not clear?) (not other-clears?) (not flonum?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) @@ -617,19 +603,6 @@ [(? lam?) (out-lam v out)] [(struct case-lam (name lams)) - (let ([seq (make-case-seq name lams)]) - ;; XXX: This seems like an optimization, which should probably happen somewhere else - ;; If all closures are empty, generate a case sequence directly - (if (andmap (lambda (lam) - (or (closure? lam) - (and (lam? lam) - (equal? (lam-closure-map lam) #())))) - lams) - (out-anything seq out) - (out-syntax CASE_LAMBDA_EXPD - seq - out)))] - [(struct case-seq (name lams)) (out-marshaled case-lambda-sequence-type-num (cons (or name null) lams) @@ -666,11 +639,11 @@ (protect-quote body)) out)] [(struct boxenv (pos body)) - (out-syntax BOXENV_EXPD - (cons - pos - (protect-quote body)) - out)] + (out-marshaled boxenv-type-num + (cons + pos + (protect-quote body)) + out)] [(struct branch (test then else)) (out-byte CPT_BRANCH out) (out-anything (protect-quote test) out) @@ -687,14 +660,10 @@ (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) - (out-syntax APPVALS_EXPD - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] - [(struct beg0 (exprs)) - (out-syntax BEGIN0_EXPD - (make-seq0 exprs) - out)] + (out-marshaled apply-values-type-num + (cons (protect-quote proc) + (protect-quote args-expr)) + out)] [(struct with-cont-mark (key val body)) (out-marshaled wcm-type-num (list* @@ -703,9 +672,9 @@ (protect-quote body)) out)] [(struct varref (expr)) - (out-syntax REF_EXPD - expr - out)] + (out-marshaled varref-form-type-num + expr + out)] [(protected-symref v) (out-anything ((out-shared-index out) v #:error? #t) out)] [(and (? symbol?) (not (? symbol-interned?))) @@ -823,10 +792,6 @@ (let-values ([(name base) (module-path-index-split v)]) (out-anything name out) (out-anything base out))] - [(module-decl content) - (out-marshaled module-type-num - content - out)] [(stx encoded) (out-byte CPT_STX out) (out-anything encoded out)] @@ -866,99 +831,96 @@ (out-bytes bstr out)] [else (error 'out-anything "~s" (current-type-trace))]))))) -(define-struct module-decl (content)) - (define (out-module mod-form out) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) - (out-syntax MODULE_EXPD - (let* ([lookup-req (lambda (phase) - (let ([a (assq phase requires)]) - (if a - (cdr a) - null)))] - [other-requires (filter (lambda (l) - (not (memq (car l) '(#f -1 0 1)))) - requires)] - [extract-protects - (lambda (phase) - (let ([a (assq phase provides)]) - (and a - (let ([p (map provided-protected? (append (cadr a) - (caddr a)))]) - (if (ormap values p) - (list->vector p) - #f)))))] - [list->vector/#f (lambda (default l) - (if (andmap (lambda (x) (equal? x default)) l) - #f - (list->vector l)))] - [l - (let loop ([l other-requires]) - (match l - [(list) - empty] - [(list-rest (cons phase reqs) rst) - (list* phase reqs (loop rst))]))] - [l (cons (length other-requires) l)] - [l (cons (lookup-req #f) l)] ; dt-requires - [l (cons (lookup-req -1) l)] ; tt-requires - [l (cons (lookup-req 1) l)] ; et-requires - [l (cons (lookup-req 0) l)] ; requires - [l (cons (list->vector body) l)] - [l (cons (list->vector - (for/list ([i (in-list syntax-body)]) - (define (maybe-one l) ;; a single symbol is ok - (if (and (pair? l) (null? (cdr l))) - (car l) - l)) - (match i - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #f)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) - l)] - [l (append (apply - append - (map (lambda (l) - (let ([phase (car l)] - [all (append (cadr l) (caddr l))]) - (list phase - (list->vector/#f #f (map provided-insp all)) - (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) - all)) - (list->vector/#f #f (map (lambda (p) - (if (eq? (provided-nom-src p) - (provided-src p)) - #f ; #f means "same as src" - (provided-nom-src p))) - all)) - (list->vector (map provided-src-name all)) - (list->vector (map provided-src all)) - (list->vector (map provided-name all)) - (length (cadr l)) - (length all)))) - provides)) - l)] - [l (cons (length provides) l)] ; number of provide sets - [l (cons (extract-protects 0) l)] ; protects - [l (cons (extract-protects 1) l)] ; et protects - [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides - [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides - [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides - [l (cons prefix l)] - [l (cons dummy l)] - [l (cons max-let-depth l)] - [l (cons internal-context l)] ; module->namespace syntax - [l (list* #f #f l)] ; obsolete `functional?' info - [l (cons lang-info l)] ; lang-info - [l (cons self-modidx l)] - [l (cons srcname l)] - [l (cons name l)]) - (make-module-decl l)) - out)])) - + (let* ([lookup-req (lambda (phase) + (let ([a (assq phase requires)]) + (if a + (cdr a) + null)))] + [other-requires (filter (lambda (l) + (not (memq (car l) '(#f -1 0 1)))) + requires)] + [extract-protects + (lambda (phase) + (let ([a (assq phase provides)]) + (and a + (let ([p (map provided-protected? (append (cadr a) + (caddr a)))]) + (if (ormap values p) + (list->vector p) + #f)))))] + [list->vector/#f (lambda (default l) + (if (andmap (lambda (x) (equal? x default)) l) + #f + (list->vector l)))] + [l + (let loop ([l other-requires]) + (match l + [(list) + empty] + [(list-rest (cons phase reqs) rst) + (list* phase reqs (loop rst))]))] + [l (cons (length other-requires) l)] + [l (cons (lookup-req #f) l)] ; dt-requires + [l (cons (lookup-req -1) l)] ; tt-requires + [l (cons (lookup-req 1) l)] ; et-requires + [l (cons (lookup-req 0) l)] ; requires + [l (cons (list->vector body) l)] + [l (cons (list->vector + (for/list ([i (in-list syntax-body)]) + (define (maybe-one l) ;; a single symbol is ok + (if (and (pair? l) (null? (cdr l))) + (car l) + l)) + (match i + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (vector (maybe-one ids) rhs max-let-depth prefix #f)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) + l)] + [l (append (apply + append + (map (lambda (l) + (let ([phase (car l)] + [all (append (cadr l) (caddr l))]) + (list phase + (list->vector/#f #f (map provided-insp all)) + (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) + all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all)))) + provides)) + l)] + [l (cons (length provides) l)] ; number of provide sets + [l (cons (extract-protects 0) l)] ; protects + [l (cons (extract-protects 1) l)] ; et protects + [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides + [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides + [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides + [l (cons prefix l)] + [l (cons dummy l)] + [l (cons max-let-depth l)] + [l (cons internal-context l)] ; module->namespace syntax + [l (list* #f #f l)] ; obsolete `functional?' info + [l (cons lang-info l)] ; lang-info + [l (cons self-modidx l)] + [l (cons srcname l)] + [l (cons name l)]) + (out-marshaled module-type-num + l + out))])) (define (lookup-encoded-wrapped w out) (hash-ref! (out-encoded-wraps out) w diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 7f8770ee44..a0f156aeac 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -200,9 +200,7 @@ (make-case-lam (car v) (cdr v))) (define (read-begin0 v) - (match v - [(struct seq (exprs)) - (make-beg0 exprs)])) + (make-beg0 v)) (define (read-boxenv v) (make-boxenv (car v) (cdr v))) @@ -213,7 +211,7 @@ (define (read-apply-values v) (make-apply-values (car v) (cdr v))) (define (read-splice v) - (make-splice (seq-forms v))) + (make-splice v)) (define (in-list* l n) (make-do-sequence @@ -303,51 +301,39 @@ ;; ---------------------------------------- ;; Unmarshal dispatch for various types -(define (read-more-syntax v) - (let ([id (car v)] - [v (cdr v)]) - ;; This is the ..._EXPD mapping from "schpriv.h": - (case id - [(0) (read-define-values v)] - [(1) (read-define-syntax v)] - [(2) (read-set! v)] - [(3) v] ; a case-lam already - [(4) (read-begin0 v)] - [(5) (read-boxenv v)] - [(6) (read-module-wrap v)] - [(7) (read-require v)] - [(8) (read-define-for-syntax v)] - [(9) (read-#%variable-ref v)] - [(10) (read-apply-values v)] - [(11) (read-splice v)] - [else (error 'read-mode-unsyntax "unknown id: ~e" id)]))) - ;; Type mappings from "stypes.h": (define (int->type i) (case i [(0) 'toplevel-type] - [(3) 'syntax-type] - [(7) 'sequence-type] - [(9) 'unclosed-procedure-type] - [(10) 'let-value-type] - [(11) 'let-void-type] - [(12) 'letrec-type] - [(14) 'with-cont-mark-type] - [(15) 'quote-syntax-type] - [(24) 'variable-type] - [(25) 'module-variable-type] - [(99) 'case-lambda-sequence-type] - [(100) 'begin0-sequence-type] - [(103) 'module-type] - [(105) 'resolve-prefix-type] - [(154) 'free-id-info-type] + [(6) 'sequence-type] + [(8) 'unclosed-procedure-type] + [(9) 'let-value-type] + [(10) 'let-void-type] + [(11) 'letrec-type] + [(13) 'with-cont-mark-type] + [(14) 'quote-syntax-type] + [(15) 'define-values-type] + [(16) 'define-syntaxes-type] + [(17) 'define-for-syntax-type] + [(18) 'set-bang-type] + [(19) 'boxenv-type] + [(20) 'begin0-sequence-type] + [(21) 'splice-sequence-type] + [(22) 'require-form-type] + [(23) 'varref-form-type] + [(24) 'apply-values-type] + [(25) 'case-lambda-sequence-type] + [(26) 'module-type] + [(34) 'variable-type] + [(35) 'module-variable-type] + [(112) 'resolve-prefix-type] + [(161) 'free-id-info-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers (make-immutable-hash (list (cons 'toplevel-type read-toplevel) - (cons 'syntax-type read-more-syntax) (cons 'sequence-type read-sequence) (cons 'unclosed-procedure-type read-unclosed-procedure) (cons 'let-value-type read-let-value) @@ -359,10 +345,19 @@ (cons 'module-variable-type do-not-read-variable) (cons 'compilation-top-type read-compilation-top) (cons 'case-lambda-sequence-type read-case-lambda) - (cons 'begin0-sequence-type read-sequence) + (cons 'begin0-sequence-type read-begin0) (cons 'module-type read-module) (cons 'resolve-prefix-type read-resolve-prefix) - (cons 'free-id-info-type read-free-id-info)))) + (cons 'free-id-info-type read-free-id-info) + (cons 'define-values-type read-define-values) + (cons 'define-syntaxes-type read-define-syntax) + (cons 'define-for-syntax-type read-define-for-syntax) + (cons 'set-bang-type read-set!) + (cons 'boxenv-type read-boxenv) + (cons 'require-form-type read-require) + (cons 'varref-form-type read-#%variable-ref) + (cons 'apply-values-type read-apply-values) + (cons 'sequence-splice-type read-splice)))) (define (get-reader type) (hash-ref type-readers type From 13e715ef44f1482245312fb80e5740a6f3d7d324 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 8 May 2011 16:57:56 -0600 Subject: [PATCH 212/466] fix decompiler's listing of captured top- and module-level variables original commit: db75dddf874d080eeaf69fcfb59fa1c0345eae7c --- collects/compiler/decompile.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 1e84e2cad0..f358015621 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -328,7 +328,8 @@ (list (for/list ([pos (in-set tl-map)]) (list-ref/protect (glob-desc-vars globs) - (if (pos . < . (glob-desc-num-tls globs)) + (if (or (pos . < . (glob-desc-num-tls globs)) + (zero? (glob-desc-num-stxs globs))) pos (+ pos (glob-desc-num-stxs globs) 1)) 'lam))))))) From ee407d66106ee7dfd111a282d449f8701415c02b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 9 May 2011 09:42:43 -0600 Subject: [PATCH 213/466] fix `varref' in `compiler/zo-structs', etc. and sync docs better with implementation original commit: a4da2a3f4cdc6ced8324de37d3a2def9d6325fc1 --- collects/compiler/decompile.rkt | 2 +- collects/compiler/demodularizer/gc-toplevels.rkt | 9 +++++---- collects/compiler/demodularizer/update-toplevels.rkt | 4 ++-- collects/compiler/zo-marshal.rkt | 4 ++-- collects/compiler/zo-parse.rkt | 2 +- collects/compiler/zo-structs.rkt | 4 ++-- 6 files changed, 13 insertions(+), 12 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index f358015621..67bdf9beb2 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -195,7 +195,7 @@ (match expr [(struct toplevel (depth pos const? ready?)) (decompile-tl expr globs stack closed #f)] - [(struct varref (tl)) + [(struct varref (tl dummy)) `(#%variable-reference ,(decompile-tl tl globs stack closed #t))] [(struct topsyntax (depth pos midpt)) (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index e03ad418a7..765513b3cb 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -120,8 +120,9 @@ [(struct beg0 (seq)) (for-each (lambda (f) (build-graph! lhs f)) seq)] - [(struct varref (tl)) - (build-graph! lhs tl)] + [(struct varref (tl dummy)) + (build-graph! lhs tl) + (build-graph! lhs dummy)] [(and f (struct assign (id rhs undef-ok?))) (build-graph! lhs id) (build-graph! lhs rhs)] @@ -252,8 +253,8 @@ (update body))] [(struct beg0 (seq)) (make-beg0 (map update seq))] - [(struct varref (tl)) - (make-varref (update tl))] + [(struct varref (tl dummy)) + (make-varref (update tl) (update dummy))] [(and f (struct assign (id rhs undef-ok?))) (struct-copy assign f [id (update id)] diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index e3cdda6110..90a7b8f2c2 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -68,8 +68,8 @@ (update body))] [(struct beg0 (seq)) (make-beg0 (map update seq))] - [(struct varref (tl)) - (make-varref (update tl))] + [(struct varref (tl dummy)) + (make-varref (update tl) (update dummy))] [(and f (struct assign (id rhs undef-ok?))) (struct-copy assign f [id (update id)] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index ced39b755c..a626ac7a7a 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -671,9 +671,9 @@ (protect-quote val) (protect-quote body)) out)] - [(struct varref (expr)) + [(struct varref (expr dummy)) (out-marshaled varref-form-type-num - expr + (cons expr dummy) out)] [(protected-symref v) (out-anything ((out-shared-index out) v #:error? #t) out)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index a0f156aeac..ac27f36b56 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -207,7 +207,7 @@ (define (read-require v) (make-req (cdr v) (car v))) (define (read-#%variable-ref v) - (make-varref v)) + (make-varref (car v) (cdr v))) (define (read-apply-values v) (make-apply-values (car v) (cdr v))) (define (read-splice v) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 2d0e920177..6d0b29574c 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -29,7 +29,7 @@ [struct id ([field-id field-contract] ...)]))) (define-struct zo () #:prefab) -(provide zo?) +(provide (struct-out zo)) (define-syntax define-form-struct (syntax-rules () @@ -167,7 +167,7 @@ [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' (define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' (define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' -(define-form-struct (varref expr) ([toplevel toplevel?])) ; `#%variable-reference' +(define-form-struct (varref expr) ([toplevel toplevel?] [dummy toplevel?])) ; `#%variable-reference' (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive From f17d94056f71201a4276732a242ea1f2157faeef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 9 May 2011 12:24:05 -0600 Subject: [PATCH 214/466] fix tl-map parse & marshal original commit: 8ad8d5b7f7f0d21ae3d7396d8b61fa3949985f9f --- collects/compiler/zo-marshal.rkt | 7 ++++--- collects/compiler/zo-parse.rkt | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index a626ac7a7a..9438fc71aa 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -978,13 +978,14 @@ num-all-params max-let-depth (and tl-map - (if (tl-map . < . #x7FFFFFFF) + (if (tl-map . <= . #xFFFFFFF) + ;; Encode as a fixnum: tl-map ;; Encode as an even-sized vector of 16-bit integers: (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) (for/vector ([i (in-range len)]) - (let ([s (* i 16)]) - (bitwise-bit-field tl-map s (+ s 16))))))) + (let ([s (* i 16)]) + (bitwise-bit-field tl-map s (+ s 16))))))) name l) out))])) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index ac27f36b56..66ee70a765 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -136,9 +136,9 @@ (and tl-map (let* ([bits (if (exact-integer? tl-map) tl-map - (for/fold ([i 0]) ([v (in-list tl-map)] + (for/fold ([i 0]) ([v (in-vector tl-map)] [s (in-naturals)]) - (bitwise-ior i (arithmetic-shift v 16))))] + (bitwise-ior i (arithmetic-shift v (* s 16)))))] [len (integer-length bits)]) (list->set (let loop ([bit 0]) From 1ca7b10829fbf9dd3d2197128f6b9896573cc666 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 7 Jun 2011 13:06:13 -0400 Subject: [PATCH 215/466] Fix "zo-parse.rkt" wrt the inclusion of `identity' in mzlib/etc, and switch to racket (making `begin-with-definitions' redundant). original commit: fc1b974cd2ea77fbfb9849b4a49fbd005418730a --- collects/compiler/zo-parse.rkt | 572 ++++++++++++++++----------------- 1 file changed, 282 insertions(+), 290 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 66ee70a765..99d6435908 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1,8 +1,7 @@ -#lang scheme/base -(require mzlib/etc - racket/function - scheme/match - scheme/list +#lang racket/base +(require racket/function + racket/match + racket/list unstable/struct compiler/zo-structs racket/dict @@ -393,12 +392,11 @@ (+ (cport-pos cp) (cport-shared-start cp))) (define (cp-getc cp) - (begin-with-definitions - (when ((cport-pos cp) . >= . (cport-size cp)) - (error "off the end")) - (define r (cport-get-byte cp (cport-pos cp))) - (set-cport-pos! cp (add1 (cport-pos cp))) - r)) + (when ((cport-pos cp) . >= . (cport-size cp)) + (error "off the end")) + (define r (cport-get-byte cp (cport-pos cp))) + (set-cport-pos! cp (add1 (cport-pos cp))) + r) (define small-list-max 65) (define cpt-table @@ -750,234 +748,228 @@ (define (read-compact cp) (let loop ([need-car 0] [proper #f]) - (begin-with-definitions - (define ch (cp-getc cp)) - (define-values (cpt-start cpt-tag) - (let ([x (cpt-table-lookup ch)]) - (unless x - (error 'read-compact "unknown code : ~a" ch)) - (values (car x) (cdr x)))) - (define v - (case cpt-tag - [(delayed) - (let ([pos (read-compact-number cp)]) - (read-sym cp pos))] - [(escape) - (let* ([len (read-compact-number cp)] - [s (cport-get-bytes cp len)]) - (set-cport-pos! cp (+ (cport-pos cp) len)) - (parameterize ([read-accept-compiled #t] - [read-accept-bar-quote #t] - [read-accept-box #t] - [read-accept-graph #t] - [read-case-sensitive #t] - [read-square-bracket-as-paren #t] - [read-curly-brace-as-paren #t] - [read-decimal-as-inexact #t] - [read-accept-dot #t] - [read-accept-infix-dot #t] - [read-accept-quasiquote #t] - [current-readtable - (make-readtable - #f - #\^ - 'dispatch-macro - (lambda (char port src line col pos) - (let ([b (read port)]) - (unless (bytes? b) - (error 'read-escaped-path - "expected a byte string after #^")) - (let ([p (bytes->path b)]) - (if (and (relative-path? p) - (current-load-relative-directory)) - (build-path (current-load-relative-directory) p) - p)))))]) - (read/recursive (open-input-bytes s))))] - [(reference) - (make-primval (read-compact-number cp))] - [(small-list small-proper-list) - (let* ([l (- ch cpt-start)] - [ppr (eq? cpt-tag 'small-proper-list)]) - (if (positive? need-car) - (if (= l 1) - (cons (read-compact cp) - (if ppr null (read-compact cp))) - (read-compact-list l ppr cp)) - (loop l ppr)))] - [(let-one let-one-flonum let-one-unused) - (make-let-one (read-compact cp) (read-compact cp) - (eq? cpt-tag 'let-one-flonum) - (eq? cpt-tag 'let-one-unused))] - [(branch) - (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] - [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))] - [(module-var) - (let ([mod (read-compact cp)] - [var (read-compact cp)] - [pos (read-compact-number cp)]) - (let-values ([(mod-phase pos) - (if (= pos -2) - (values 1 (read-compact-number cp)) - (values 0 pos))]) - (make-module-variable mod var pos mod-phase)))] - [(local-unbox) - (let* ([p* (read-compact-number cp)] - [p (if (< p* 0) - (- (add1 p*)) - p*)] - [flags (if (< p* 0) - (read-compact-number cp) - 0)]) - (make-local #t p flags))] - [(path) - (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))]) - (if (relative-path? p) - (path->complete-path p (or (current-load-relative-directory) - (current-directory))) - p))] - [(small-number) - (let ([l (- ch cpt-start)]) - l)] - [(int) - (read-compact-number cp)] - [(false) #f] - [(true) #t] - [(null) null] - [(void) (void)] - [(vector) - ; XXX We should provide build-immutable-vector and write this as: - #;(build-immutable-vector (read-compact-number cp) - (lambda (i) (read-compact cp))) - ; XXX Now it allocates an unnessary list AND vector - (let* ([n (read-compact-number cp)] - [lst (for/list ([i (in-range n)]) - (read-compact cp))]) - (vector->immutable-vector (list->vector lst)))] - [(pair) - (let* ([a (read-compact cp)] - [d (read-compact cp)]) - (cons a d))] - [(list) - (let ([len (read-compact-number cp)]) - (let loop ([i len]) - (if (zero? i) - (read-compact cp) - (list* (read-compact cp) - (loop (sub1 i))))))] - [(prefab) - (let ([v (read-compact cp)]) - ; XXX This is faster than apply+->list, but can we avoid allocating the vector? - (call-with-values (lambda () (vector->values v)) - make-prefab-struct))] - [(hash-table) - ; XXX Allocates an unnessary list (maybe use for/hash(eq)) - (let ([eq (read-compact-number cp)] - [len (read-compact-number cp)]) - ((case eq - [(0) make-hasheq-placeholder] - [(1) make-hash-placeholder] - [(2) make-hasheqv-placeholder]) - (for/list ([i (in-range len)]) - (cons (read-compact cp) - (read-compact cp)))))] - [(marshalled) (read-marshalled (read-compact-number cp) cp)] - [(stx) - (let ([v (make-reader-graph (read-compact cp))]) - (make-stx (decode-stx cp v)))] - [(local local-unbox) - (let ([c (read-compact-number cp)] - [unbox? (eq? cpt-tag 'local-unbox)]) - (if (negative? c) - (make-local unbox? (- (add1 c)) (read-compact-number cp)) - (make-local unbox? c 0)))] - [(small-local) - (make-local #f (- ch cpt-start) 0)] - [(small-local-unbox) - (make-local #t (- ch cpt-start) 0)] - [(small-symbol) - (let ([l (- ch cpt-start)]) - (string->symbol (read-compact-chars cp l)))] - [(symbol) - (let ([l (read-compact-number cp)]) - (string->symbol (read-compact-chars cp l)))] - [(keyword) - (let ([l (read-compact-number cp)]) - (string->keyword (read-compact-chars cp l)))] - [(byte-string) - (let ([l (read-compact-number cp)]) - (read-compact-bytes cp l))] - [(string) - (let ([l (read-compact-number cp)] - [cl (read-compact-number cp)]) - (read-compact-chars cp l))] - [(char) - (integer->char (read-compact-number cp))] - [(box) - (box (read-compact cp))] - [(quote) - (make-reader-graph - ;; Nested escapes need to share graph references. So get inside the - ;; read where `read/recursive' can be used: - (let ([rt (current-readtable)]) - (parameterize ([current-readtable (make-readtable - #f - #\x 'terminating-macro - (lambda args - (parameterize ([current-readtable rt]) - (read-compact cp))))]) - (read (open-input-bytes #"x")))))] - [(symref) - (let* ([l (read-compact-number cp)]) - (read-sym cp l))] - [(weird-symbol) - (let ([uninterned (read-compact-number cp)] - [str (read-compact-chars cp (read-compact-number cp))]) - (if (= 1 uninterned) - ; uninterned is equivalent to weird in the C implementation - (string->uninterned-symbol str) - ; unreadable is equivalent to parallel in the C implementation - (string->unreadable-symbol str)))] - [(small-marshalled) - (read-marshalled (- ch cpt-start) cp)] - [(small-application2) + (define ch (cp-getc cp)) + (define-values (cpt-start cpt-tag) + (let ([x (cpt-table-lookup ch)]) + (unless x + (error 'read-compact "unknown code : ~a" ch)) + (values (car x) (cdr x)))) + (define v + (case cpt-tag + [(delayed) + (let ([pos (read-compact-number cp)]) + (read-sym cp pos))] + [(escape) + (let* ([len (read-compact-number cp)] + [s (cport-get-bytes cp len)]) + (set-cport-pos! cp (+ (cport-pos cp) len)) + (parameterize ([read-accept-compiled #t] + [read-accept-bar-quote #t] + [read-accept-box #t] + [read-accept-graph #t] + [read-case-sensitive #t] + [read-square-bracket-as-paren #t] + [read-curly-brace-as-paren #t] + [read-decimal-as-inexact #t] + [read-accept-dot #t] + [read-accept-infix-dot #t] + [read-accept-quasiquote #t] + [current-readtable + (make-readtable + #f + #\^ + 'dispatch-macro + (lambda (char port src line col pos) + (let ([b (read port)]) + (unless (bytes? b) + (error 'read-escaped-path + "expected a byte string after #^")) + (let ([p (bytes->path b)]) + (if (and (relative-path? p) + (current-load-relative-directory)) + (build-path (current-load-relative-directory) p) + p)))))]) + (read/recursive (open-input-bytes s))))] + [(reference) + (make-primval (read-compact-number cp))] + [(small-list small-proper-list) + (let* ([l (- ch cpt-start)] + [ppr (eq? cpt-tag 'small-proper-list)]) + (if (positive? need-car) + (if (= l 1) + (cons (read-compact cp) + (if ppr null (read-compact cp))) + (read-compact-list l ppr cp)) + (loop l ppr)))] + [(let-one let-one-flonum let-one-unused) + (make-let-one (read-compact cp) (read-compact cp) + (eq? cpt-tag 'let-one-flonum) + (eq? cpt-tag 'let-one-unused))] + [(branch) + (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] + [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))] + [(module-var) + (let ([mod (read-compact cp)] + [var (read-compact cp)] + [pos (read-compact-number cp)]) + (let-values ([(mod-phase pos) + (if (= pos -2) + (values 1 (read-compact-number cp)) + (values 0 pos))]) + (make-module-variable mod var pos mod-phase)))] + [(local-unbox) + (let* ([p* (read-compact-number cp)] + [p (if (< p* 0) (- (add1 p*)) p*)] + [flags (if (< p* 0) (read-compact-number cp) 0)]) + (make-local #t p flags))] + [(path) + (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))]) + (if (relative-path? p) + (path->complete-path p (or (current-load-relative-directory) + (current-directory))) + p))] + [(small-number) + (let ([l (- ch cpt-start)]) + l)] + [(int) + (read-compact-number cp)] + [(false) #f] + [(true) #t] + [(null) null] + [(void) (void)] + [(vector) + ; XXX We should provide build-immutable-vector and write this as: + #;(build-immutable-vector (read-compact-number cp) + (lambda (i) (read-compact cp))) + ; XXX Now it allocates an unnessary list AND vector + (let* ([n (read-compact-number cp)] + [lst (for/list ([i (in-range n)]) (read-compact cp))]) + (vector->immutable-vector (list->vector lst)))] + [(pair) + (let* ([a (read-compact cp)] + [d (read-compact cp)]) + (cons a d))] + [(list) + (let ([len (read-compact-number cp)]) + (let loop ([i len]) + (if (zero? i) + (read-compact cp) + (list* (read-compact cp) + (loop (sub1 i))))))] + [(prefab) + (let ([v (read-compact cp)]) + ; XXX This is faster than apply+->list, but can we avoid allocating the vector? + (call-with-values (lambda () (vector->values v)) + make-prefab-struct))] + [(hash-table) + ; XXX Allocates an unnessary list (maybe use for/hash(eq)) + (let ([eq (read-compact-number cp)] + [len (read-compact-number cp)]) + ((case eq + [(0) make-hasheq-placeholder] + [(1) make-hash-placeholder] + [(2) make-hasheqv-placeholder]) + (for/list ([i (in-range len)]) + (cons (read-compact cp) + (read-compact cp)))))] + [(marshalled) (read-marshalled (read-compact-number cp) cp)] + [(stx) + (let ([v (make-reader-graph (read-compact cp))]) + (make-stx (decode-stx cp v)))] + [(local local-unbox) + (let ([c (read-compact-number cp)] + [unbox? (eq? cpt-tag 'local-unbox)]) + (if (negative? c) + (make-local unbox? (- (add1 c)) (read-compact-number cp)) + (make-local unbox? c 0)))] + [(small-local) + (make-local #f (- ch cpt-start) 0)] + [(small-local-unbox) + (make-local #t (- ch cpt-start) 0)] + [(small-symbol) + (let ([l (- ch cpt-start)]) + (string->symbol (read-compact-chars cp l)))] + [(symbol) + (let ([l (read-compact-number cp)]) + (string->symbol (read-compact-chars cp l)))] + [(keyword) + (let ([l (read-compact-number cp)]) + (string->keyword (read-compact-chars cp l)))] + [(byte-string) + (let ([l (read-compact-number cp)]) + (read-compact-bytes cp l))] + [(string) + (let ([l (read-compact-number cp)] + [cl (read-compact-number cp)]) + (read-compact-chars cp l))] + [(char) + (integer->char (read-compact-number cp))] + [(box) + (box (read-compact cp))] + [(quote) + (make-reader-graph + ;; Nested escapes need to share graph references. So get inside the + ;; read where `read/recursive' can be used: + (let ([rt (current-readtable)]) + (parameterize ([current-readtable (make-readtable + #f + #\x 'terminating-macro + (lambda args + (parameterize ([current-readtable rt]) + (read-compact cp))))]) + (read (open-input-bytes #"x")))))] + [(symref) + (let* ([l (read-compact-number cp)]) + (read-sym cp l))] + [(weird-symbol) + (let ([uninterned (read-compact-number cp)] + [str (read-compact-chars cp (read-compact-number cp))]) + (if (= 1 uninterned) + ; uninterned is equivalent to weird in the C implementation + (string->uninterned-symbol str) + ; unreadable is equivalent to parallel in the C implementation + (string->unreadable-symbol str)))] + [(small-marshalled) + (read-marshalled (- ch cpt-start) cp)] + [(small-application2) + (make-application (read-compact cp) + (list (read-compact cp)))] + [(small-application3) + (make-application (read-compact cp) + (list (read-compact cp) + (read-compact cp)))] + [(small-application) + (let ([c (add1 (- ch cpt-start))]) (make-application (read-compact cp) - (list (read-compact cp)))] - [(small-application3) + (for/list ([i (in-range (sub1 c))]) + (read-compact cp))))] + [(application) + (let ([c (read-compact-number cp)]) (make-application (read-compact cp) - (list (read-compact cp) - (read-compact cp)))] - [(small-application) - (let ([c (add1 (- ch cpt-start))]) - (make-application (read-compact cp) - (for/list ([i (in-range (sub1 c))]) - (read-compact cp))))] - [(application) - (let ([c (read-compact-number cp)]) - (make-application (read-compact cp) - (for/list ([i (in-range c)]) - (read-compact cp))))] - [(closure) - (read-compact-number cp) ; symbol table pos. our marshaler will generate this - (let ([v (read-compact cp)]) - (make-closure - v - (gensym - (let ([s (lam-name v)]) - (cond - [(symbol? s) s] - [(vector? s) (vector-ref s 0)] - [else 'closure])))))] - [(svector) - (read-compact-svector cp (read-compact-number cp))] - [(small-svector) - (read-compact-svector cp (- ch cpt-start))] - [else (error 'read-compact "unknown tag ~a" cpt-tag)])) - (cond - [(zero? need-car) v] - [(and proper (= need-car 1)) - (cons v null)] - [else - (cons v (loop (sub1 need-car) proper))])))) + (for/list ([i (in-range c)]) + (read-compact cp))))] + [(closure) + (read-compact-number cp) ; symbol table pos. our marshaler will generate this + (let ([v (read-compact cp)]) + (make-closure + v + (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure])))))] + [(svector) + (read-compact-svector cp (read-compact-number cp))] + [(small-svector) + (read-compact-svector cp (- ch cpt-start))] + [else (error 'read-compact "unknown tag ~a" cpt-tag)])) + (cond + [(zero? need-car) v] + [(and proper (= need-car 1)) + (cons v null)] + [else + (cons v (loop (sub1 need-car) proper))]))) (define (unmarshal-stx-get/decode cp pos decode-stx) (define v2 (read-sym cp pos)) @@ -1003,9 +995,9 @@ (if (memq i (mark-parameter-all read-sym-mark)) ph ; Otherwise, try to read it and return the real thing - (local [(define vv (placeholder-get ph))] + (let ([vv (placeholder-get ph)]) (when (not-ready? vv) - (local [(define save-pos (cport-pos cp))] + (let ([save-pos (cport-pos cp)]) (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) (mark-parameterize ([read-sym-mark i]) @@ -1017,55 +1009,55 @@ ;; path -> bytes ;; implementes read.c:read_compiled (define (zo-parse [port (current-input-port)]) - (begin-with-definitions - ;; skip the "#~" - (unless (equal? #"#~" (read-bytes 2 port)) - (error 'zo-parse "not a bytecode stream")) - - (define version (read-bytes (min 63 (read-byte port)) port)) + ;; skip the "#~" + (unless (equal? #"#~" (read-bytes 2 port)) + (error 'zo-parse "not a bytecode stream")) - ;; Skip module hash code - (read-bytes 20 port) - - (define symtabsize (read-simple-number port)) - - (define all-short (read-byte port)) - - (define cnt (* (if (not (zero? all-short)) 2 4) - (sub1 symtabsize))) - - (define so (read-bytes cnt port)) - - (define so* (list->vector (split-so all-short so))) - - (define shared-size (read-simple-number port)) - (define size* (read-simple-number port)) - - (when (shared-size . >= . size*) - (error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)")) - - (define rst-start (file-position port)) - - (file-position port (+ rst-start size*)) - - (unless (eof-object? (read-byte port)) - (error 'zo-parse "File too big")) - - (define nr (make-not-ready)) - (define symtab - (build-vector symtabsize (λ (i) (make-placeholder nr)))) - - (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) - - (for ([i (in-range 1 symtabsize)]) - (read-sym cp i)) - - #;(printf "Parsed table:\n") - #;(for ([(i v) (in-dict (cport-symtab cp))]) - (printf "~a = ~a\n" i (placeholder-get v)) ) - (set-cport-pos! cp shared-size) - (make-reader-graph - (read-marshalled 'compilation-top-type cp)))) + (define version (read-bytes (min 63 (read-byte port)) port)) + + ;; Skip module hash code + (read-bytes 20 port) + + (define symtabsize (read-simple-number port)) + + (define all-short (read-byte port)) + + (define cnt (* (if (not (zero? all-short)) 2 4) + (sub1 symtabsize))) + + (define so (read-bytes cnt port)) + + (define so* (list->vector (split-so all-short so))) + + (define shared-size (read-simple-number port)) + (define size* (read-simple-number port)) + + (when (shared-size . >= . size*) + (error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)")) + + (define rst-start (file-position port)) + + (file-position port (+ rst-start size*)) + + (unless (eof-object? (read-byte port)) + (error 'zo-parse "File too big")) + + (define nr (make-not-ready)) + (define symtab + (build-vector symtabsize (λ (i) (make-placeholder nr)))) + + (define cp + (make-cport 0 shared-size port size* rst-start symtab so* + (make-vector symtabsize #f) (make-hash) (make-hash))) + + (for ([i (in-range 1 symtabsize)]) + (read-sym cp i)) + + #;(printf "Parsed table:\n") + #;(for ([(i v) (in-dict (cport-symtab cp))]) + (printf "~a = ~a\n" i (placeholder-get v))) + (set-cport-pos! cp shared-size) + (make-reader-graph (read-marshalled 'compilation-top-type cp))) ;; ---------------------------------------- @@ -1078,12 +1070,12 @@ (compile sexp)) s) (get-output-bytes s)) - - (define (compile/parse sexp) + + (define (compile/parse sexp) (let* ([bs (compile/write sexp)] [p (open-input-bytes bs)]) (zo-parse p))) - + #;(compile/parse #s(foo 10 13)) (zo-parse (open-input-file "/home/mflatt/proj/plt/collects/scheme/private/compiled/more-scheme_ss.zo")) ) From f90858601d55f2bba592b179cf2932b0a49ef948 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 28 Jun 2011 02:01:41 -0400 Subject: [PATCH 216/466] A long overdue scan to eliminate files without terminating newlines. (DrRacket should really do that.) original commit: 40124a0619da5e187d95aeb1dde237f05d6f9c6b --- collects/compiler/demodularizer/alpha.rkt | 2 +- collects/compiler/demodularizer/batch.rkt | 2 +- collects/compiler/demodularizer/gc-toplevels.rkt | 2 +- collects/compiler/demodularizer/merge.rkt | 2 +- collects/compiler/demodularizer/module.rkt | 2 +- collects/compiler/demodularizer/mpi.rkt | 2 +- collects/compiler/demodularizer/nodep.rkt | 2 +- collects/compiler/demodularizer/util.rkt | 2 +- collects/tests/compiler/demodularizer/demod-test.rkt | 2 +- .../tests/compiler/demodularizer/tests/kernel-5.rkt | 2 +- .../tests/compiler/demodularizer/tests/racket-5.rkt | 2 +- collects/tests/compiler/regression.rkt | 2 +- collects/tests/compiler/zo-exs.rkt | 10 +++++----- collects/tests/compiler/zo-test-util.rkt | 2 +- collects/tests/compiler/zo-test-worker.rkt | 2 +- 15 files changed, 19 insertions(+), 19 deletions(-) diff --git a/collects/compiler/demodularizer/alpha.rkt b/collects/compiler/demodularizer/alpha.rkt index 7ca1b83e1a..9b459b6ca3 100644 --- a/collects/compiler/demodularizer/alpha.rkt +++ b/collects/compiler/demodularizer/alpha.rkt @@ -16,4 +16,4 @@ (prefix-toplevels p))])) (provide/contract - [alpha-vary-ctop (compilation-top? . -> . compilation-top?)]) \ No newline at end of file + [alpha-vary-ctop (compilation-top? . -> . compilation-top?)]) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 97ec868b12..9846a958b8 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -110,4 +110,4 @@ Here's the idea: [("-e" "--exclude-modules") mod "Exclude a module from being batched" (current-excluded-modules (set-add (current-excluded-modules) mod))] - #:args (filename) (main filename)) \ No newline at end of file + #:args (filename) (main filename)) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index 765513b3cb..1118214a8e 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -275,4 +275,4 @@ first-update) (provide/contract - [gc-toplevels (compilation-top? . -> . compilation-top?)]) \ No newline at end of file + [gc-toplevels (compilation-top? . -> . compilation-top?)]) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index f25dd63166..5c63e6d22b 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -170,4 +170,4 @@ (provide/contract [merge-compilation-top (-> get-modvar-rewrite/c compilation-top? - compilation-top?)]) \ No newline at end of file + compilation-top?)]) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index faa47c49e7..48253dd7e2 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -31,4 +31,4 @@ #t))])) (provide/contract - [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)]) \ No newline at end of file + [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)]) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index 3c86837115..10f8cd23a5 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -28,4 +28,4 @@ [MODULE-PATHS (parameter/c (or/c false/c hash?))] [current-module-path (parameter/c path-string?)] [mpi->path! (module-path-index? . -> . (or/c symbol? path?))] - [mpi->path* (module-path-index? . -> . (or/c symbol? path?))]) \ No newline at end of file + [mpi->path* (module-path-index? . -> . (or/c symbol? path?))]) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 0d8c01642d..56a5818450 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -186,4 +186,4 @@ [get-modvar-rewrite/c contract?] [current-excluded-modules (parameter/c set?)] [nodep-file (-> path-string? - (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) \ No newline at end of file + (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 1334e2911b..717dee8994 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -77,4 +77,4 @@ (values (unconstrained-domain-> any/c) (unconstrained-domain-> any/c)))] [lang-info/c contract?] - [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) \ No newline at end of file + [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) diff --git a/collects/tests/compiler/demodularizer/demod-test.rkt b/collects/tests/compiler/demodularizer/demod-test.rkt index dec2f03a96..ae13457942 100644 --- a/collects/tests/compiler/demodularizer/demod-test.rkt +++ b/collects/tests/compiler/demodularizer/demod-test.rkt @@ -46,4 +46,4 @@ (define ip (build-path tests i)) (when (modular-program? ip) (printf "Checking ~a\n" ip) - (test-on-program (path->string ip))))) \ No newline at end of file + (test-on-program (path->string ip))))) diff --git a/collects/tests/compiler/demodularizer/tests/kernel-5.rkt b/collects/tests/compiler/demodularizer/tests/kernel-5.rkt index 2cee709c7f..9b75f464c6 100644 --- a/collects/tests/compiler/demodularizer/tests/kernel-5.rkt +++ b/collects/tests/compiler/demodularizer/tests/kernel-5.rkt @@ -2,4 +2,4 @@ (#%require racket/private/map) (define-values (id) (λ (x) x)) (define-values (xs) (list 1 2 3 4 5)) - (map id (map id xs))) \ No newline at end of file + (map id (map id xs))) diff --git a/collects/tests/compiler/demodularizer/tests/racket-5.rkt b/collects/tests/compiler/demodularizer/tests/racket-5.rkt index a48b41da12..e4d92af6b9 100644 --- a/collects/tests/compiler/demodularizer/tests/racket-5.rkt +++ b/collects/tests/compiler/demodularizer/tests/racket-5.rkt @@ -1,2 +1,2 @@ #lang racket -5 \ No newline at end of file +5 diff --git a/collects/tests/compiler/regression.rkt b/collects/tests/compiler/regression.rkt index 4a2b58fdc4..4e6e8825ff 100644 --- a/collects/tests/compiler/regression.rkt +++ b/collects/tests/compiler/regression.rkt @@ -14,4 +14,4 @@ (set-cookie name val))) (test - (cookie? (make-cookie "name" "value"))) \ No newline at end of file + (cookie? (make-cookie "name" "value"))) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index c395604236..fbf325980f 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -103,14 +103,14 @@ (list (current-directory)))) (roundtrip - (compilation-top - 0 + (compilation-top + 0 (prefix 0 empty empty) (cons #hash() #hash()))) (roundtrip - (compilation-top - 0 + (compilation-top + 0 (prefix 0 empty empty) - #hash()))) \ No newline at end of file + #hash()))) diff --git a/collects/tests/compiler/zo-test-util.rkt b/collects/tests/compiler/zo-test-util.rkt index cf5c40bd34..95dbc1c85b 100644 --- a/collects/tests/compiler/zo-test-util.rkt +++ b/collects/tests/compiler/zo-test-util.rkt @@ -9,4 +9,4 @@ [struct failure ([phase symbol?] [serious? boolean?] [msg string?])] - [struct success ([phase symbol?])]) \ No newline at end of file + [struct success ([phase symbol?])]) diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt index 8442fb74f6..e46284548d 100644 --- a/collects/tests/compiler/zo-test-worker.rkt +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -267,4 +267,4 @@ (command-line #:program "zo-test-worker" #:args (file) - (run-test file)) \ No newline at end of file + (run-test file)) From ae337220711e92052b2617a2b12c75b7cdc36f12 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 29 Jun 2011 21:33:59 -0600 Subject: [PATCH 217/466] fix `compiler/zo-parse' & co. original commit: 69ad39d45c206c4283d62c5a0d1ab6da6fab9a9d --- collects/compiler/zo-marshal.rkt | 21 ++++--------- collects/compiler/zo-parse.rkt | 53 +++++++++++--------------------- collects/compiler/zo-structs.rkt | 15 ++------- 3 files changed, 26 insertions(+), 63 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 9438fc71aa..124b01c48c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -304,7 +304,7 @@ (for/list ([wrap (in-list wraps)]) (match wrap [(struct phase-shift (amt src dest)) - (box (vector amt src dest #f))] + (box (vector amt src dest #f #f))] [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) (define encoded-kind (eq? kind 'marked)) (define encoded-unmarshals (map encode-all-from-module unmarshals)) @@ -343,18 +343,9 @@ (define-struct protected-symref (val)) -(define encode-certs - (match-lambda - [(struct certificate:nest (m1 m2)) - (list* (encode-mark-map m1) (encode-mark-map m2))] - [(struct certificate:ref (val m)) - (list* #f (make-protected-symref val) (encode-mark-map m))] - [(struct certificate:plain (m)) - (encode-mark-map m)])) - (define (encode-wrapped w) (match w - [(struct wrapped (datum wraps certs)) + [(struct wrapped (datum wraps tamper-status)) (let* ([enc-datum (match datum [(cons a b) @@ -391,9 +382,10 @@ [_ datum])] [p (cons enc-datum (encode-wraps wraps))]) - (if certs - (vector p (encode-certs certs)) - p))])) + (case tamper-status + [(clean) p] + [(tainted) (vector p)] + [(armed) (vector p #f)]))])) (define-struct out (s shared-index shared-unsee encoded-wraps)) (define (out-shared v out k) @@ -887,7 +879,6 @@ (let ([phase (car l)] [all (append (cadr l) (caddr l))]) (list phase - (list->vector/#f #f (map provided-insp all)) (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) all)) (list->vector/#f #f (map (lambda (p) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 99d6435908..287498ba73 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -232,8 +232,8 @@ ,indirect-provides ,num-indirect-provides ,protects ,et-protects ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 9 provide-phase-count))]) - (match (list-tail rest (* 9 provide-phase-count)) + (let ([phase-data (take rest (* 8 provide-phase-count))]) + (match (list-tail rest (* 8 provide-phase-count)) [`(,syntax-body ,body ,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) @@ -241,34 +241,31 @@ prefix (let loop ([l phase-data]) (if (null? l) null - (let ([num-vars (list-ref l 7)] - [ps (for/list ([name (in-vector (list-ref l 6))] - [src (in-vector (list-ref l 5))] - [src-name (in-vector (list-ref l 4))] - [nom-src (or (list-ref l 3) + (let ([num-vars (list-ref l 6)] + [ps (for/list ([name (in-vector (list-ref l 5))] + [src (in-vector (list-ref l 4))] + [src-name (in-vector (list-ref l 3))] + [nom-src (or (list-ref l 2) (in-cycle (in-value #f)))] - [src-phase (or (list-ref l 2) + [src-phase (or (list-ref l 1) (in-cycle (in-value #f)))] [protected? (or (case (car l) [(0) protects] [(1) et-protects] [else #f]) - (in-cycle (in-value #f)))] - [insp (or (list-ref l 1) - (in-cycle (in-value #f)))]) + (in-cycle (in-value #f)))]) (make-provided name src src-name (or nom-src src) (if src-phase 1 0) - protected? - insp))]) + protected?))]) (if (null? ps) - (loop (list-tail l 9)) + (loop (list-tail l 8)) (cons (list (car l) (take ps num-vars) (drop ps num-vars)) - (loop (list-tail l 9))))))) + (loop (list-tail l 8))))))) (list* (cons 0 requires) (cons 1 syntax-requires) @@ -527,20 +524,6 @@ (define (decode-mark-map alist) alist) -(define marks-memo (make-memo)) -(define (decode-marks cp ms) - (with-memo marks-memo ms - (match ms - [#f #f] - [(list* #f (? number? symref) alist) - (make-certificate:ref - (symtab-lookup cp symref) - (decode-mark-map alist))] - [(list* (? list? nested) alist) - (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))] - [alist - (make-certificate:plain (decode-mark-map alist))]))) - (define stx-memo (make-memo)) ; XXX More memo use (define (decode-stx cp v) @@ -548,15 +531,15 @@ (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) - (let-values ([(cert-marks v encoded-wraps) + (let-values ([(tamper-status v encoded-wraps) (match v - [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] - [`(,datum . ,wraps) (values #f datum wraps)] + [`#((,datum . ,wraps)) (values 'tainted datum wraps)] + [`#((,datum . ,wraps) #f) (values 'armed datum wraps)] + [`(,datum . ,wraps) (values 'clean datum wraps)] [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) (let* ([wraps (decode-wraps cp encoded-wraps)] - [marks (decode-marks cp cert-marks)] [wrapped-memo (make-memo)] - [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))]) + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps tamper-status)))]) (cond [(pair? v) (if (eq? #t (car v)) @@ -652,7 +635,7 @@ [(box? a) (match (unbox a) [(list (? symbol?) ...) (make-prune (unbox a))] - [`#(,amt ,src ,dest #f) + [`#(,amt ,src ,dest #f #f) (make-phase-shift amt (parse-module-path-index cp src) (parse-module-path-index cp dest))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 6d0b29574c..e7223113ff 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -57,21 +57,11 @@ (define mark-map? (alist/c number? module-path-index?) #;(hash/c number? module-path-index?)) -(define-form-struct certificate ()) -(define-form-struct (certificate:nest certificate) - ([nested mark-map?] - [map mark-map?])) -(define-form-struct (certificate:ref certificate) - ([val any/c] - [map mark-map?])) -(define-form-struct (certificate:plain certificate) - ([map mark-map?])) - (define-form-struct wrap ()) (define-form-struct wrapped ([datum any/c] [wraps (listof wrap?)] - [certs (or/c certificate? #f)])) + [tamper-status (or/c 'clean 'armed 'tainted)])) ;; In stxs of prefix: (define-form-struct stx ([encoded wrapped?])) @@ -91,8 +81,7 @@ [src-name symbol?] [nom-src any/c] ; should be (or/c module-path-index? #f) [src-phase (or/c 0 1)] - [protected? boolean?] - [insp (or/c boolean? void?)])) + [protected? boolean?])) (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] From b5181ff032b0a0fe84b4ebafc8ba661086d7f22b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 1 Jul 2011 22:44:48 -0600 Subject: [PATCH 218/466] adapt demodularizer to `compiler/zo-struct' change original commit: 98740390faeb8ccd0ffe6d74f4f227d3dfd09ecd --- collects/compiler/demodularizer/nodep.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 56a5818450..b9d7a8eb79 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -163,13 +163,13 @@ empty (begin (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))] + (list (make-req (make-stx (make-wrapped ct empty 'clean)) (make-toplevel 0 0 #f #f)))))] [(module-path-index? ct) (if (hash-has-key? REQUIRED ct) empty (begin (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))] + (list (make-req (make-stx (make-wrapped ct empty 'clean)) (make-toplevel 0 0 #f #f)))))] [(not ct) empty] [(@phase? ct) From 2f65de9812785f692968823e1511f7c60e340d32 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 2 Jul 2011 10:37:53 -0400 Subject: [PATCH 219/466] ".ss" -> ".rkt" scan done. original commit: 3157955d40f89d83fb3d5fa7a2f20639cda69579 --- collects/compiler/commands/make.rkt | 2 +- collects/tests/racket/embed-planet-1/alt.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 74f2b85ae7..fc237ce2b8 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -2,7 +2,7 @@ (require scheme/cmdline raco/command-name compiler/cm - "../compiler.ss" + "../compiler.rkt" dynext/file setup/parallel-build racket/match) diff --git a/collects/tests/racket/embed-planet-1/alt.rkt b/collects/tests/racket/embed-planet-1/alt.rkt index 197192d70e..abb8992b46 100644 --- a/collects/tests/racket/embed-planet-1/alt.rkt +++ b/collects/tests/racket/embed-planet-1/alt.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require "main.ss") +(require "main.rkt") (with-output-to-file "stdout" #:exists 'append From 1f9a6339e424ac771405462127616ef35d789001 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 6 Jul 2011 19:58:26 -0600 Subject: [PATCH 220/466] fix decompile of define-values-for-syntax original commit: 5bc8b67ebaf9a3191f4fae2e926b582033b593ab --- collects/compiler/decompile.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 67bdf9beb2..7e4586ef1b 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -138,7 +138,7 @@ ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-expr rhs globs '(#%globals) closed))))] + ,(decompile-form rhs globs '(#%globals) closed))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) (decompile-form form globs stack closed)) From 32d8828ab5944e06d0f48301684c521d58ff3874 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 7 Jul 2011 14:47:19 -0600 Subject: [PATCH 221/466] improve decompiler handling of syntax object original commit: 5e49e0adea49996ad67a405ed6fecd6d16ea7111 --- collects/compiler/decompile.rkt | 105 +++++++++++++++++++++++++------- 1 file changed, 84 insertions(+), 21 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 7e4586ef1b..f6831c0900 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -47,15 +47,16 @@ ;; Main entry: (define (decompile top) - (match top - [(struct compilation-top (max-let-depth prefix form)) - (let-values ([(globs defns) (decompile-prefix prefix)]) - `(begin - ,@defns - ,(decompile-form form globs '(#%globals) (make-hasheq))))] - [else (error 'decompile "unrecognized: ~e" top)])) + (let ([stx-ht (make-hasheq)]) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) + `(begin + ,@defns + ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht)))] + [else (error 'decompile "unrecognized: ~e" top)]))) -(define (decompile-prefix a-prefix) +(define (decompile-prefix a-prefix stx-ht) (match a-prefix [(struct prefix (num-lifts toplevels stxs)) (let ([lift-ids (for/list ([i (in-range num-lifts)]) @@ -89,37 +90,99 @@ num-lifts) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,(stx-encoded stx)) + `(#%decode-syntax + ,(decompile-stx (stx-encoded stx) stx-ht)) #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) +(define (decompile-stx stx stx-ht) + (or (hash-ref stx-ht stx #f) + (let ([p (mcons #f #f)]) + (hash-set! stx-ht stx p) + (match stx + [(wrapped datum wraps tamper-status) + (set-mcar! p (case tamper-status + [(clean) 'wrap] + [(tainted) 'wrap-tainted] + [(armed) 'wrap-armed])) + (set-mcdr! p (mcons + (cond + [(pair? datum) + (cons (decompile-stx (car datum) stx-ht) + (let loop ([l (cdr datum)]) + (cond + [(null? l) null] + [(pair? l) + (cons (decompile-stx (car l) stx-ht) + (loop (cdr l)))] + [else + (decompile-stx l stx-ht)])))] + [(vector? datum) + (for/vector ([e (in-vector datum)]) + (decompile-stx e stx-ht))] + [(box? datum) + (box (decompile-stx (unbox datum) stx-ht))] + [else datum]) + (let loop ([wraps wraps]) + (cond + [(null? wraps) null] + [else + (or (hash-ref stx-ht wraps #f) + (let ([p (mcons #f #f)]) + (hash-set! stx-ht wraps p) + (set-mcar! p (decompile-wrap (car wraps) stx-ht)) + (set-mcdr! p (loop (cdr wraps))) + p))])))) + p])))) + +(define (decompile-wrap w stx-ht) + (or (hash-ref stx-ht w #f) + (let ([v (match w + [(lexical-rename has-free-id-renames? + ignored + alist) + `(,(if has-free-id-renames? 'lexical/free-id=? 'lexical) . ,alist)] + [(phase-shift amt src dest) + `(phase-shift ,amt ,src ,dest)] + [(wrap-mark val) + val] + [(prune sym) + `(prune ,sym)] + [(module-rename phase kind set-id unmarshals renames mark-renames plus-kern?) + `(module-rename ,phase ,kind ,set-id ,unmarshals ,renames ,mark-renames ,plus-kern?)] + [(top-level-rename flag) + `(top-level-rename ,flag)] + [else w])]) + (hash-set! stx-ht w v) + v))) + (define (mpi->string modidx) (cond [(symbol? modidx) modidx] [else (collapse-module-path-index modidx (current-directory))])) -(define (decompile-module mod-form stack) +(define (decompile-module mod-form stack stx-ht) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) - (let-values ([(globs defns) (decompile-prefix prefix)] + (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [(stack) (append '(#%modvars) stack)] [(closed) (make-hasheq)]) `(module ,name .... ,@defns ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) syntax-body) ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) body)))] [else (error 'decompile-module "huh?: ~e" mod-form)])) -(define (decompile-form form globs stack closed) +(define (decompile-form form globs stack closed stx-ht) (match form [(? mod?) - (decompile-module form stack)] + (decompile-module form stack stx-ht)] [(struct def-values (ids rhs)) `(define-values ,(map (lambda (tl) (match tl @@ -129,23 +192,23 @@ ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) `(define-syntaxes ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix)]) + ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) `(let () ,@defns - ,(decompile-form rhs globs '(#%globals) closed))))] + ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] [(struct def-for-syntax (ids rhs prefix max-let-depth)) `(define-values-for-syntax ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix)]) + ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) `(let () ,@defns - ,(decompile-form rhs globs '(#%globals) closed))))] + ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) forms))] [(struct splice (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) forms))] [(struct req (reqs dummy)) `(#%require . (#%decode-syntax ,reqs))] From 481f10a62263e653fed3729b07fea8c333b2e539 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Jul 2011 16:16:04 -0600 Subject: [PATCH 222/466] fix zo-parse of rename tables original commit: 07a9cdd2a8bbd2f9f9bce791e2329a453d349c77 --- collects/compiler/zo-parse.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 287498ba73..ad5b848872 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -595,8 +595,8 @@ ; A reference [(integer? a) (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] - ; A mark (not actually a number as the C says, but a (list ) - [(and (pair? a) (number? (car a))) + ; A mark wraped in a list + [(and (pair? a) (number? (car a)) (null? (cdr a))) (make-wrap-mark (car a))] [(vector? a) From eaed2b9eaf2bfcf5adf19af2f1de275652f8e0de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 Jul 2011 22:19:19 -0400 Subject: [PATCH 223/466] fix compiler/zo-parse for sequence splice Merge to 5.1.2 original commit: 42f41d868a133751722a426467168005d8cfb0ef --- collects/compiler/zo-parse.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index ad5b848872..d1aaf68478 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -353,7 +353,7 @@ (cons 'require-form-type read-require) (cons 'varref-form-type read-#%variable-ref) (cons 'apply-values-type read-apply-values) - (cons 'sequence-splice-type read-splice)))) + (cons 'splice-sequence-type read-splice)))) (define (get-reader type) (hash-ref type-readers type From eec721ff4ca4acddfa5474484740d5bf22121138 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Aug 2011 08:58:30 -0600 Subject: [PATCH 224/466] generalize `#%variable-reference' and add `variable-reference-constant?' Use the new functions to make the expansion of keyword applications to known procedure work with mutation. original commit: 5352d670c401ebd4346f4dbd855a81c078193de4 --- collects/compiler/decompile.rkt | 4 +++- collects/compiler/zo-structs.rkt | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index f6831c0900..ca9b60c7a5 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -259,7 +259,9 @@ [(struct toplevel (depth pos const? ready?)) (decompile-tl expr globs stack closed #f)] [(struct varref (tl dummy)) - `(#%variable-reference ,(decompile-tl tl globs stack closed #t))] + `(#%variable-reference ,(if (eq? tl #t) + ' + (decompile-tl tl globs stack closed #t)))] [(struct topsyntax (depth pos midpt)) (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] [(struct primval (id)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index e7223113ff..86c8052a15 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -156,7 +156,7 @@ [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' (define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' (define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' -(define-form-struct (varref expr) ([toplevel toplevel?] [dummy toplevel?])) ; `#%variable-reference' +(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive From 053734c4c8c3e00d3faa47ad153f61c5bb18cdab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Aug 2011 03:34:56 -0600 Subject: [PATCH 225/466] fix compiler handling of top-/module-level constants The JIT and bytecode compiler disagreed on the definition of "constant". Now there are two levels: "constant" means constant across all instantiations, and "fixed" means constant for a given instantation. The JIT uses this distinction to generate direct-primitive calls or not. (Without the distinction, a direct jump to `reverse' could be wrong, because `racket/base' might get instantiated with the JIT disabled or not.) Also, fixed a bug in the JIT's `vector-set!' code in the case that the target vector is a top-/module-level reference that is ready, fixed, or constant. original commit: 7eb2042bd9296235ae425fcc56a05931a65d47d4 --- collects/compiler/decompile.rkt | 14 +++++++++----- collects/compiler/zo-marshal.rkt | 4 ++-- collects/compiler/zo-parse.rkt | 7 +++++-- 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index ca9b60c7a5..903e6843ef 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -186,7 +186,7 @@ [(struct def-values (ids rhs)) `(define-values ,(map (lambda (tl) (match tl - [(struct toplevel (depth pos const? mutated?)) + [(struct toplevel (depth pos const? set-const?)) (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) ids) ,(decompile-expr rhs globs stack closed))] @@ -250,10 +250,14 @@ (match expr [(struct toplevel (depth pos const? ready?)) (let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)]) - (if (or no-check? const? ready?) - id - `(#%checked ,id)))])) - + (cond + [no-check? id] + [(and (not const?) (not ready?)) + `(#%checked ,id)] + #;[(and const? ready?) `(#%const ,id)] + #;[const? `(#%iconst ,id)] + [else id]))])) + (define (decompile-expr expr globs stack closed) (match expr [(struct toplevel (depth pos const? ready?)) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 124b01c48c..e435a97080 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -554,8 +554,8 @@ (if (or const? ready?) (cons pos (bitwise-ior - (if const? #x1 0) - (if ready? #x2 0))) + (if const? #x2 0) + (if ready? #x1 0))) pos)) out)] [(struct topsyntax (depth pos midpt)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index d1aaf68478..3c559ec62b 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -33,10 +33,13 @@ ;; Bytecode unmarshalers for various forms (define (read-toplevel v) - (define SCHEME_TOPLEVEL_CONST #x01) - (define SCHEME_TOPLEVEL_READY #x02) + (define SCHEME_TOPLEVEL_CONST #x02) + (define SCHEME_TOPLEVEL_READY #x01) (match v [(cons depth (cons pos flags)) + ;; In the VM, the two flag bits are actually interpreted + ;; as a number when the toplevel is a reference, but we + ;; interpret the bits as flags here for backward compatibility. (make-toplevel depth pos (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))] From 77ba4327f77ec96f70d14d11cdb713e936c236d3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Aug 2011 11:43:23 -0600 Subject: [PATCH 226/466] fix `compile-collection-zos' original commit: bdadc453e030222d939937b8867114b768c1aabc --- collects/tests/compiler/collection-zos.rkt | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 collects/tests/compiler/collection-zos.rkt diff --git a/collects/tests/compiler/collection-zos.rkt b/collects/tests/compiler/collection-zos.rkt new file mode 100644 index 0000000000..f74074d856 --- /dev/null +++ b/collects/tests/compiler/collection-zos.rkt @@ -0,0 +1,5 @@ +#lang racket +(require compiler/compiler) + +;; minimal sanity check: +(compile-collection-zos "setup") From dd20d04fff95cf9ff973818e5742eea77f8e794f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Aug 2011 14:18:38 -0600 Subject: [PATCH 227/466] add `raco unpack' Although the ".plt" format is going to be replaced, the format is currently viable for distributing collections, and I have wanted a raw `unpack' command for a while. It was useful today to fix problems with `raco pack' and collection links. original commit: 2dbaa45e1b35e3a1a8b4ddcb70637744e876a9d1 --- collects/compiler/commands/info.rkt | 1 + collects/compiler/commands/unpack.rkt | 102 ++++++++++++++++++++++++++ 2 files changed, 103 insertions(+) create mode 100644 collects/compiler/commands/unpack.rkt diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index d97e168309..e20ae53b7d 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -4,6 +4,7 @@ '(("make" compiler/commands/make "compile source to bytecode" 100) ("exe" compiler/commands/exe "create executable" 20) ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) + ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" 10) ("decompile" compiler/commands/decompile "decompile bytecode" #f) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) diff --git a/collects/compiler/commands/unpack.rkt b/collects/compiler/commands/unpack.rkt new file mode 100644 index 0000000000..2c2a1cfdd7 --- /dev/null +++ b/collects/compiler/commands/unpack.rkt @@ -0,0 +1,102 @@ +#lang scheme/base +(require scheme/cmdline + raco/command-name + setup/unpack + racket/file + racket/port + racket/match + racket/string + racket/pretty) + +(define verbose (make-parameter #f)) + +(define just-show? (make-parameter #f)) +(define replace? (make-parameter #f)) +(define show-config? (make-parameter #f)) + +(define mzc-symbol (string->symbol (short-program+command-name))) + +(define files + (command-line + #:program (short-program+command-name) + #:once-each + [("-l" "--list") "just list archive content" + (just-show? #t)] + [("-c" "--config") "show archive configuration" + (show-config? #t)] + [("-f" "--force") "replace existing files when unpacking" + (replace? #t)] + #:args archive + archive)) + +(define (desc->path dir) + (if (path? dir) + dir + (apply build-path + (symbol->string (car dir)) + (cdr dir)))) + +(for ([filename (in-list files)]) + (fold-plt-archive filename + (lambda (config a) + (when (show-config?) + (match config + [`(lambda (request failure) + (case request + ((name) ,name) + ((unpacker) (quote mzscheme)) + ((requires) (quote ,reqs)) + ((conflicts) (quote ,conflicts)) + ((plt-relative?) ,plt-rel?) + ((plt-home-relative?) ,plt-home-rel?) + ((test-plt-dirs) ,test-plt-dirs) + (else (failure)))) + (printf "config:\n") + (printf " name: ~s\n" name) + (printf " requires:\n") + (for ([c (in-list reqs)]) + (printf " ~s ~s\n" (string-join (car c) "/") (cadr c))) + (printf " conflicts:\n") + (for ([c (in-list conflicts)]) + (printf " ~s\n" (string-join c "/"))) + (cond + [plt-home-rel? (printf " unpack to main installation\n")] + [plt-rel? (printf " unpack to user add-ons\n")] + [else (printf " unpack locally\n")])] + [else + (printf "config function:\n") + (pretty-write config)])) + a) + (lambda (setup i a) + (when (show-config?) + (match setup + [`(unit (import main-collects-parent-dir mzuntar) (export) (mzuntar void) (quote ,c)) + (printf "setup collections:\n") + (for ([c (in-list c)]) + (printf " ~s\n" (string-join c "/")))] + [else + (printf "setup unit:\n") + (pretty-write setup)])) + a) + (lambda (dir a) + (unless (eq? dir 'same) + (if (just-show?) + (printf "~a\n" (path->directory-path (desc->path dir))) + (make-directory* (desc->path dir)))) + a) + (lambda (file i kind a) + (if (just-show?) + (printf "~a~a\n" (desc->path file) + (if (eq? kind 'file-replace) + " [replace]" + "")) + (call-with-output-file* + (desc->path file) + #:exists (if (or (eq? kind 'file-replace) + (replace?)) + 'truncate/replace + 'error) + (lambda (o) + (copy-port i o)))) + a) + (void))) From d622961559bc0ffe5089dac1572b8f0ecbc0f431 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Aug 2011 09:14:29 -0600 Subject: [PATCH 228/466] change `raco exe' to disable collection lookup by default original commit: ecc058de4a4af5ea41865af689a247481805edee --- collects/compiler/commands/exe.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index 117e44429b..2bd1ec1473 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -14,7 +14,7 @@ (define exe-embedded-flags (make-parameter '("-U" "--"))) (define exe-embedded-libraries (make-parameter null)) (define exe-aux (make-parameter null)) -(define exe-embedded-collects-path (make-parameter #f)) +(define exe-embedded-collects-path (make-parameter null)) (define exe-embedded-collects-dest (make-parameter #f)) (define source-file From 116108745644692ba8dc9c205a9a261a696cd567 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Sep 2011 23:53:13 -0500 Subject: [PATCH 229/466] remove extraneous path->string conversion original commit: bb71539233dcb28f641b5537d61797bee4eabcaa --- collects/compiler/commands/make.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index fc237ce2b8..127b521795 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -66,7 +66,7 @@ (lambda (p) (set! did-one? #t) (when (verbose) - (printf " making ~s\n" (path->string p))))]) + (printf " making ~s\n" p)))]) (for ([file source-files]) (unless (file-exists? file) (error mzc-symbol "file does not exist: ~a" file)) From 278f090e8376656fd9e8a2eab9140581f6cb5986 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Sep 2011 16:08:16 -0600 Subject: [PATCH 230/466] generalized `begin-for-syntax' original commit: d3c56c9f13327d07513f8b6bf7ea0230acb7f489 --- collects/compiler/decompile.rkt | 25 +-- .../compiler/demodularizer/gc-toplevels.rkt | 4 +- collects/compiler/demodularizer/merge.rkt | 3 +- collects/compiler/demodularizer/nodep.rkt | 5 +- .../demodularizer/update-toplevels.rkt | 2 +- collects/compiler/zo-marshal.rkt | 103 +++++++----- collects/compiler/zo-parse.rkt | 159 +++++++++++------- collects/compiler/zo-structs.rkt | 27 +-- collects/tests/compiler/zo.rkt | 40 +++++ 9 files changed, 229 insertions(+), 139 deletions(-) create mode 100644 collects/tests/compiler/zo.rkt diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 903e6843ef..053ad00fb9 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -164,16 +164,20 @@ (define (decompile-module mod-form stack stx-ht) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [(stack) (append '(#%modvars) stack)] [(closed) (make-hasheq)]) `(module ,name .... ,@defns - ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) - syntax-body) + ,@(for/list ([b (in-list syntax-bodies)]) + (let loop ([n (sub1 (car b))]) + (if (zero? n) + (cons 'begin + (for/list ([form (in-list (cdr b))]) + (decompile-form form globs stack closed stx-ht))) + (list 'begin-for-syntax (loop (sub1 n)))))) ,@(map (lambda (form) (decompile-form form globs stack closed stx-ht)) body)))] @@ -190,18 +194,19 @@ (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) ids) ,(decompile-expr rhs globs stack closed))] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) `(let () ,@defns ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - `(define-values-for-syntax ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(let () + [(struct seq-for-syntax (exprs prefix max-let-depth dummy)) + `(begin-for-syntax + ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) + `(let () ,@defns - ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] + ,@(for/list ([rhs (in-list exprs)]) + (decompile-form rhs globs '(#%globals) closed stx-ht)))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) (decompile-form form globs stack closed stx-ht)) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index 1118214a8e..f212b66081 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -64,7 +64,7 @@ (build-graph! new-lhs rhs)] [(? def-syntaxes?) (error 'build-graph "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'build-graph "Doesn't handle syntax")] [(struct req (reqs dummy)) (build-graph! lhs dummy)] @@ -197,7 +197,7 @@ #f)] [(? def-syntaxes?) (error 'gc-tls "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'gc-tls "Doesn't handle syntax")] [(struct req (reqs dummy)) (make-req reqs (update dummy))] diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 5c63e6d22b..6e57f5962c 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -108,7 +108,8 @@ (define (merge-module max-let-depth top-prefix mod-form) (match mod-form - [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context)) + [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies + unexported mod-max-let-depth dummy lang-info internal-context)) (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index b9d7a8eb79..c37f82ceea 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -112,7 +112,8 @@ (define (nodep-module mod-form phase) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies + unexported max-let-depth dummy lang-info internal-context)) (define new-prefix prefix) ; Cache all the mpi paths (for-each (match-lambda @@ -127,7 +128,7 @@ (append (requires->modlist requires phase) (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx new-prefix provides requires body empty + (list (make-mod name srcname self-modidx new-prefix provides requires body syntax-bodies empty unexported max-let-depth dummy lang-info internal-context))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 90a7b8f2c2..15584bb5d3 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -10,7 +10,7 @@ (update rhs))] [(? def-syntaxes?) (error 'increment "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'increment "Doesn't handle syntax")] [(struct req (reqs dummy)) (make-req reqs (update dummy))] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e435a97080..22f5d5b95e 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -158,7 +158,7 @@ (define quote-syntax-type-num 14) (define define-values-type-num 15) (define define-syntaxes-type-num 16) -(define define-for-syntax-type-num 17) +(define begin-for-syntax-type-num 17) (define set-bang-type-num 18) (define boxenv-type-num 19) (define begin0-sequence-type-num 20) @@ -256,8 +256,6 @@ (define BITS_PER_MZSHORT 32) -(define *dummy* #f) - (define (int->bytes x) (integer->integer-bytes x 4 @@ -522,21 +520,20 @@ (out-marshaled define-values-type-num (list->vector (cons (protect-quote rhs) ids)) out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) (out-marshaled define-syntaxes-type-num (list->vector (list* (protect-quote rhs) prefix max-let-depth - *dummy* + dummy ids)) out)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-marshaled define-for-syntax-type-num - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) + [(struct seq-for-syntax (rhs prefix max-let-depth dummy)) + (out-marshaled begin-for-syntax-type-num + (vector (map protect-quote rhs) + prefix + max-let-depth + dummy) out)] [(struct beg0 (forms)) (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] @@ -825,7 +822,7 @@ (define (out-module mod-form out) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context)) (let* ([lookup-req (lambda (phase) (let ([a (assq phase requires)]) @@ -844,6 +841,11 @@ (if (ormap values p) (list->vector p) #f)))))] + [extract-unexported + (lambda (phase) + (let ([a (assq phase unexported)]) + (and a + (cdr a))))] [list->vector/#f (lambda (default l) (if (andmap (lambda (x) (equal? x default)) l) #f @@ -861,45 +863,54 @@ [l (cons (lookup-req 1) l)] ; et-requires [l (cons (lookup-req 0) l)] ; requires [l (cons (list->vector body) l)] - [l (cons (list->vector - (for/list ([i (in-list syntax-body)]) - (define (maybe-one l) ;; a single symbol is ok - (if (and (pair? l) (null? (cdr l))) - (car l) - l)) - (match i - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #f)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) - l)] + [l (append (reverse + (for/list ([b (in-list syntax-bodies)]) + (for/vector ([i (in-list (cdr b))]) + (define (maybe-one l) ;; a single symbol is ok + (if (and (pair? l) (null? (cdr l))) + (car l) + l)) + (match i + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) + (vector (maybe-one ids) rhs max-let-depth prefix #f)] + [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy)) + (vector #f rhs max-let-depth prefix #t)])))) + l)] [l (append (apply append (map (lambda (l) - (let ([phase (car l)] - [all (append (cadr l) (caddr l))]) - (list phase - (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) - all)) - (list->vector/#f #f (map (lambda (p) - (if (eq? (provided-nom-src p) - (provided-src p)) - #f ; #f means "same as src" - (provided-nom-src p))) - all)) - (list->vector (map provided-src-name all)) - (list->vector (map provided-src all)) - (list->vector (map provided-name all)) - (length (cadr l)) - (length all)))) + (let* ([phase (car l)] + [all (append (cadr l) (caddr l))] + [protects (extract-protects phase)] + [unexported (extract-unexported phase)]) + (append + (list phase) + (if (and (not protects) + (not unexported)) + (list (void)) + (let ([unexported (or unexported + '(() ()))]) + (list (list->vector (cadr unexported)) + (length (cadr unexported)) + (list->vector (car unexported)) + (length (car unexported)) + protects))) + (list (list->vector/#f 0 (map provided-src-phase all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all))))) provides)) l)] [l (cons (length provides) l)] ; number of provide sets - [l (cons (extract-protects 0) l)] ; protects - [l (cons (extract-protects 1) l)] ; et protects - [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides - [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides - [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides + [l (cons (add1 (length syntax-bodies)) l)] [l (cons prefix l)] [l (cons dummy l)] [l (cons max-let-depth l)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 3c559ec62b..468c27fe21 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -181,19 +181,19 @@ (cdr (vector->list v)) (vector-ref v 0))) -; XXX Allocates unnessary list -(define (read-define-syntaxes mk v) - (mk (list-tail (vector->list v) 4) - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - #;(vector-ref v 3))) - (define (read-define-syntax v) - (read-define-syntaxes make-def-syntaxes v)) + (make-def-syntaxes (list-tail (vector->list v) 4) + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) -(define (read-define-for-syntax v) - (read-define-syntaxes make-def-for-syntax v)) +(define (read-begin-for-syntax v) + (make-seq-for-syntax + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) (define (read-set! v) (make-assign (cadr v) (cddr v) (car v))) @@ -225,50 +225,65 @@ (lambda _ #t) (lambda _ #t))))) +(define (split-phase-data rest n) + (let loop ([n n] [rest rest] [phase-accum null]) + (cond + [(zero? n) + (values (reverse phase-accum) rest)] + [else + (let ([maybe-indirect (list-ref rest 1)]) + (if (void? maybe-indirect) + ;; no indirect or protect info: + (loop (sub1 n) + (list-tail rest 9) + (cons (take rest 9) phase-accum)) + ;; has indirect or protect info: + (loop (sub1 n) + (list-tail rest (+ 5 8)) + (cons (take rest (+ 5 8)) phase-accum))))]))) + (define (read-module v) (match v [`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy - ,prefix - ,indirect-et-provides ,num-indirect-et-provides - ,indirect-syntax-provides ,num-indirect-syntax-provides - ,indirect-provides ,num-indirect-provides - ,protects ,et-protects + ,prefix ,num-phases ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 8 provide-phase-count))]) - (match (list-tail rest (* 8 provide-phase-count)) - [`(,syntax-body ,body - ,requires ,syntax-requires ,template-requires ,label-requires - ,more-requires-count . ,more-requires) + (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)] + [(bodies rest-module) (values (take rest-module num-phases) + (drop rest-module num-phases))]) + (match rest-module + [`(,requires ,syntax-requires ,template-requires ,label-requires + ,more-requires-count . ,more-requires) (make-mod name srcname self-modidx - prefix (let loop ([l phase-data]) - (if (null? l) - null - (let ([num-vars (list-ref l 6)] - [ps (for/list ([name (in-vector (list-ref l 5))] - [src (in-vector (list-ref l 4))] - [src-name (in-vector (list-ref l 3))] - [nom-src (or (list-ref l 2) - (in-cycle (in-value #f)))] - [src-phase (or (list-ref l 1) - (in-cycle (in-value #f)))] - [protected? (or (case (car l) - [(0) protects] - [(1) et-protects] - [else #f]) - (in-cycle (in-value #f)))]) - (make-provided name src src-name - (or nom-src src) - (if src-phase 1 0) - protected?))]) - (if (null? ps) - (loop (list-tail l 8)) - (cons - (list - (car l) - (take ps num-vars) - (drop ps num-vars)) - (loop (list-tail l 8))))))) + prefix + ;; provides: + (for/list ([l (in-list phase-data)]) + (let* ([phase (list-ref l 0)] + [has-info? (not (void? (list-ref l 1)))] + [delta (if has-info? 5 1)] + [num-vars (list-ref l (+ delta 6))] + [num-all (list-ref l (+ delta 7))] + [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))] + [src (in-vector (list-ref l (+ delta 4)))] + [src-name (in-vector (list-ref l (+ delta 3)))] + [nom-src (or (list-ref l (+ delta 2)) + (in-cycle (in-value #f)))] + [src-phase (or (list-ref l (+ delta 1)) + (in-cycle (in-value 0)))] + [protected? (cond + [(or (not has-info?) + (not (list-ref l 5))) + (in-cycle (in-value #f))] + [else (list-ref l 5)])]) + (make-provided name src src-name + (or nom-src src) + src-phase + protected?))]) + (list + phase + (take ps num-vars) + (drop ps num-vars)))) + ;; requires: (list* (cons 0 requires) (cons 1 syntax-requires) @@ -276,20 +291,34 @@ (cons #f label-requires) (for/list ([(phase reqs) (in-list* more-requires 2)]) (cons phase reqs))) - (vector->list body) - (map (lambda (sb) - (match sb - [(? def-syntaxes?) sb] - [(? def-for-syntax?) sb] - [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) - ((if for-stx? - make-def-for-syntax - make-def-syntaxes) - (if (list? ids) ids (list ids)) expr prefix max-let-depth)])) - (vector->list syntax-body)) - (list (vector->list indirect-provides) - (vector->list indirect-syntax-provides) - (vector->list indirect-et-provides)) + ;; body: + (vector->list (last bodies)) + ;; syntax-bodies: add phase to each list, break apart + (for/list ([b (cdr (reverse bodies))] + [i (in-naturals 1)]) + (cons i + (for/list ([sb (in-vector b)]) + (match sb + [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) + (if for-stx? + (make-seq-for-syntax (list expr) prefix max-let-depth #f) + (make-def-syntaxes + (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))] + [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)])))) + ;; unexported: + (for/list ([l (in-list phase-data)] + #:when (not (void? (list-ref l 1)))) + (let* ([phase (list-ref l 0)] + [indirect-syntax + ;; could check: (list-ref l 2) should be size of vector: + (list-ref l 1)] + [indirect + ;; could check: (list-ref l 4) should be size of vector: + (list-ref l 3)]) + (list + phase + (vector->list indirect) + (vector->list indirect-syntax)))) max-let-depth dummy lang-info @@ -313,7 +342,7 @@ [(14) 'quote-syntax-type] [(15) 'define-values-type] [(16) 'define-syntaxes-type] - [(17) 'define-for-syntax-type] + [(17) 'begin-for-syntax-type] [(18) 'set-bang-type] [(19) 'boxenv-type] [(20) 'begin0-sequence-type] @@ -350,7 +379,7 @@ (cons 'free-id-info-type read-free-id-info) (cons 'define-values-type read-define-values) (cons 'define-syntaxes-type read-define-syntax) - (cons 'define-for-syntax-type read-define-for-syntax) + (cons 'begin-for-syntax-type read-begin-for-syntax) (cons 'set-bang-type read-set!) (cons 'boxenv-type read-boxenv) (cons 'require-form-type read-require) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 86c8052a15..d1ed02537d 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -80,7 +80,7 @@ [src (or/c module-path-index? #f)] [src-name symbol?] [nom-src any/c] ; should be (or/c module-path-index? #f) - [src-phase (or/c 0 1)] + [src-phase exact-nonnegative-integer?] [protected? boolean?])) (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] @@ -89,18 +89,19 @@ [ready? boolean?])) ; access binding via prefix array (which is on stack) (define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' +(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax' + [prefix prefix?] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) ;; Definitions (top level or within module): -(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? +(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] [rhs (or/c expr? seq? any/c)])) -(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? +(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] [rhs (or/c expr? seq? any/c)] [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])) -(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? any/c)] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])) + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) (define-form-struct (mod form) ([name symbol?] [srcname symbol?] @@ -111,10 +112,12 @@ (listof provided?)))] [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] - [body (listof (or/c form? any/c))] - [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] - [unexported (list/c (listof symbol?) (listof symbol?) - (listof symbol?))] + [body (listof (or/c form? any/c))] + [syntax-bodies (listof (cons/c exact-positive-integer? + (listof (or/c def-syntaxes? seq-for-syntax?))))] + [unexported (listof (list/c exact-nonnegative-integer? + (listof symbol?) + (listof symbol?)))] [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] diff --git a/collects/tests/compiler/zo.rkt b/collects/tests/compiler/zo.rkt new file mode 100644 index 0000000000..84b3bd6951 --- /dev/null +++ b/collects/tests/compiler/zo.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require racket/pretty + compiler/zo-parse + compiler/zo-marshal + compiler/decompile) + +(define ex-mod1 + '(module m racket + (begin-for-syntax + (define fs 10) + (list fs)) + (define-syntax (m stx) + #'10) + (m) + (begin-for-syntax + (list fs)))) + +(define ex-mod2 + '(module m racket + (define t 8) + (define s 10) + (provide t (protect-out s)))) + +(define (check ex-mod) + (let ([c (parameterize ([current-namespace (make-base-namespace)]) + (compile ex-mod))]) + (let ([o (open-output-bytes)]) + (write c o) + (let ([p (zo-parse (open-input-bytes (get-output-bytes o)))]) + (let ([b (zo-marshal p)]) + (let ([p2 (zo-parse (open-input-bytes b))] + [to-string (lambda (p) + (let ([o (open-output-bytes)]) + (print p o) + (get-output-string o)))]) + (unless (equal? (to-string p) (to-string p2)) + (error 'zo "failed on example: ~e" ex-mod)))))))) + +(check ex-mod1) +(check ex-mod2) From c663b1e957b32efe3f37a53dee00f23ec99461aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 8 Sep 2011 19:19:14 -0600 Subject: [PATCH 231/466] fix demod for `begin-for-syntax' changes original commit: b1eab296f4e0f48152f82efed382f4674310f2ef --- collects/compiler/demodularizer/module.rkt | 2 +- collects/compiler/demodularizer/nodep.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 48253dd7e2..0bf82da22c 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -24,7 +24,7 @@ (list (cons 0 requires)) new-forms empty ; syntax-body - (list empty empty empty) ; unexported + (list) ; unexported max-let-depth (make-toplevel 0 0 #f #f) ; dummy lang-info diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index c37f82ceea..68cc899241 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -128,7 +128,7 @@ (append (requires->modlist requires phase) (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx new-prefix provides requires body syntax-bodies empty + (list (make-mod name srcname self-modidx new-prefix provides requires body empty unexported max-let-depth dummy lang-info internal-context))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] From 569f5e20a9dc143acecb4c916d7c3098cc3f0c80 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 14 Sep 2011 16:53:45 -0400 Subject: [PATCH 232/466] Some selective `#:when (not ...)' -> `#:unless ...'. original commit: 623c7493ed2bbf7c89caea877a7b94a5f4c42c73 --- collects/compiler/zo-parse.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 468c27fe21..6c9493537b 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -307,7 +307,7 @@ [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)])))) ;; unexported: (for/list ([l (in-list phase-data)] - #:when (not (void? (list-ref l 1)))) + #:unless (void? (list-ref l 1))) (let* ([phase (list-ref l 0)] [indirect-syntax ;; could check: (list-ref l 2) should be size of vector: From 9f5362d806d2cd318ee64fa32aa9e9ad5bf76c9f Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Fri, 16 Sep 2011 13:06:29 -0600 Subject: [PATCH 233/466] Fix pr 12205 pass --disable-inline and --vv options through to parallel make original commit: 099e89a29760dcf90d126b199d774cd9410f802f --- collects/compiler/commands/make.rkt | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 127b521795..56f8ebc1e2 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -91,4 +91,13 @@ (match type ['done (when (verbose) (printf " Made ~a\n" work))] ['output (printf " Output from: ~a\n~a~a" work out err)] - [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])))]) + [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])) + #:options + (let ([cons-if-true (lambda (bool carv cdrv) + (if bool + (cons carv cdrv) + cdrv))]) + (cons-if-true + (very-verbose) + 'very-verbose + (cons-if-true (disable-inlining) 'disable-inlining null))))]) From 701a815db1aa7e5edf960ca79612948a06524bb6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Sep 2011 14:55:58 -0600 Subject: [PATCH 234/466] remove obsolete and unused Racket-to-C compiler Removes `raco ctool -e/-c', `mzc -e/-c', `compile-extensions', `compile-extensions-to-c', `compile-c-extensions', `compiler/cffi', `compiler/comp-unit', `compiler:inner^', and most options in `compiler/option'. original commit: 0ab6637539c56c717535fe864a63e251cc0768e0 --- collects/compiler/sig.rkt | 56 ++------------------------------------- 1 file changed, 2 insertions(+), 54 deletions(-) diff --git a/collects/compiler/sig.rkt b/collects/compiler/sig.rkt index a635eb1ab4..63267b13c5 100644 --- a/collects/compiler/sig.rkt +++ b/collects/compiler/sig.rkt @@ -4,8 +4,7 @@ (require mzlib/unit) (provide compiler:option^ - compiler^ - compiler:inner^) + compiler^) ;; Compiler options (define-signature compiler:option^ @@ -21,61 +20,17 @@ ; the public names of loaded extensions ; default = "" - clean-intermediate-files ; #t => keep intermediate .c/.o files - ; default = #f - 3m ; #t => build for 3m ; default = #f compile-subcollections ; #t => compile collection subdirectories ; default = #t - compile-for-embedded ; #f => make objects to be linked - ; directly with Racket, not dynamically - ; loaded; default = #f - - max-inline-size ; max size of inlined procedures - - disable-interrupts ; #t => UNSAFE: turn off breaking, stack - ; overflow, and thread switching; - ; default = #f - unsafe ; #t => UNSAFE: omit some type checks - ; default = #f - fixnum-arithmetic ; #t => UNSAFE: don't check for overflow or - ; underflow for fixnum arithmetic; - ; default = #f - - propagate-constants ; default = #t - assume-primitives ; #t => car = #%car; default = #f - stupid ; allow obvious non-syntactic errors; - ; e.g.: ((lambda () 0) 1 2 3) - - vehicles ; Controls how closures are compiled: - ; 'vehicles:automatic, - ; 'vehicles:functions, - ; 'vechicles:units, or - ; 'vehicles:monolithic. - ; default = 'vehicles:automatic - vehicles:monoliths ; Size for 'vehicles:monolithic - seed ; Randomizer seed for 'vehicles:monolithic - - max-exprs-per-top-level-set ; Number of top-level Scheme expressions - ; crammed into one C function; default = 25 - - unpack-environments ; default = #t - ; Maybe #f helps for register-poor architectures? - - debug ; #t => creates debug.txt debugging file - test ; #t => ignores top-level expressions with syntax errors )) ;; Compiler procedures (define-signature compiler^ - (compile-extensions - compile-extensions-to-c - compile-c-extensions - - compile-zos + (compile-zos compile-collection-zos compile-directory-zos @@ -83,10 +38,3 @@ current-compiler-dynamic-require-wrapper compile-notify-handler)) - -;; Low-level extension compiler interface -(define-signature compiler:inner^ - (compile-extension - compile-extension-to-c - compile-c-extension - eval-compile-prefix)) From a849681b7d5cc352ea07bc1d20ddfcd7517c21b0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 5 Oct 2011 09:32:43 -0600 Subject: [PATCH 235/466] remove `raco exe' plot test original commit: fe1909581ba0fcb1a0596bd7e342b9e67bbb7f4c --- collects/tests/racket/embed.rktl | 18 +----------------- 1 file changed, 1 insertion(+), 17 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 25924e8f06..8186067b57 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -377,23 +377,7 @@ "--gui-exe" (path->string (mk-dest #t)) (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) - (try-exe (mk-dest #t) "This is 5: #\n" #t)) - - ;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: - (parameterize ([current-directory (find-system-path 'temp-dir)]) - (define direct (build-path (find-system-path 'temp-dir) "direct.ps")) - - (test #t - system* (build-path (find-console-bin-dir) "mred") - "-qu" - (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) - (path->string direct)) - - (system* mzc - "--gui-exe" - (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) - (try-exe (mk-dest #t) "plotted\n" #t))) + (try-exe (mk-dest #t) "This is 5: #\n" #t))) ;; Try including source that needs a reader extension From 7d7888d2ba4efa3498513ec6445485bedba31aaa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 5 Oct 2011 19:12:15 -0600 Subject: [PATCH 236/466] fix compiler bug related to lifting and unbox flonums As variables are dropped for lifted functions, the bitmap for flonum closure variables was not shifted down by the number of dropped variables. Closes PR 12259 original commit: 7680adf486d875dc75d2f5b13a94fc907b36498e --- collects/compiler/zo-parse.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 6c9493537b..5f47e9cc54 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -111,12 +111,15 @@ (case (check-bit i) [(0) 'val] [(1) 'ref] - [(2) 'flonum])))] + [(2) 'flonum] + [else (error "both 'ref and 'flonum argument?")])))] [(closure-types) (for/list ([i (in-range closure-size)] [j (in-naturals num-params)]) (case (check-bit j) [(0) 'val/ref] - [(2) 'flonum]))]) + [(1) (error "invalid 'ref closure variable")] + [(2) 'flonum] + [else (error "both 'ref and 'flonum closure var?")]))]) (make-lam name (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) From 9d2461bca5af9d05f940e252662146247a164578 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 7 Oct 2011 10:08:09 -0600 Subject: [PATCH 237/466] more `raco exe' cycle repairs original commit: b6a9330bf1e9a3b5cfc177b1d091f8f2dae38086 --- collects/tests/racket/embed-me13.rkt | 4 ++++ collects/tests/racket/embed-me14.rkt | 5 +++++ collects/tests/racket/embed.rktl | 4 +++- 3 files changed, 12 insertions(+), 1 deletion(-) create mode 100644 collects/tests/racket/embed-me13.rkt create mode 100644 collects/tests/racket/embed-me14.rkt diff --git a/collects/tests/racket/embed-me13.rkt b/collects/tests/racket/embed-me13.rkt new file mode 100644 index 0000000000..a29c30b53e --- /dev/null +++ b/collects/tests/racket/embed-me13.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require racket/runtime-path) +(define-runtime-module-path-index _mod "embed-me14.rkt") +(dynamic-require _mod #f) diff --git a/collects/tests/racket/embed-me14.rkt b/collects/tests/racket/embed-me14.rkt new file mode 100644 index 0000000000..0de4c9e9a2 --- /dev/null +++ b/collects/tests/racket/embed-me14.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "embed-me13.rkt") +(with-output-to-file "stdout" + (lambda () (printf "This is 14\n")) + #:exists 'append) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 8186067b57..be92fb8b7b 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -216,6 +216,8 @@ (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) + (one-mz-test "embed-me13.rkt" "This is 14\n" #f) + (one-mz-test "embed-me14.rkt" "This is 14\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -304,7 +306,7 @@ (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (test #f system* (mk-dest mred?)) - + (void))) (define (try-mzc) From 52fa72bd6b02105664442c70fea9782f0c5ce1d6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 29 Nov 2011 20:20:05 -0700 Subject: [PATCH 238/466] first cut at cross-module function inlining Inline only trivial functions, such as `(empty? x)' -> `(null? x)', to avoid generating too much code. Bytecode includes a new `inline-variant' form, which records a version of a function that is suitable for cross-module inlining. Mostly, the variant let the run-time system to retain a copy of the bytecode while JITting (and dropping the bytecode of) the main variant, but it may be different from the main variant in other ways that make it better for inlining (such a less loop unrolling). original commit: 779b419c03f294fb696f765e37dae1f1c73a263d --- collects/compiler/decompile.rkt | 7 ++++++- collects/compiler/zo-marshal.rkt | 8 ++++---- collects/compiler/zo-parse.rkt | 13 +++++++++---- collects/compiler/zo-structs.rkt | 5 ++++- 4 files changed, 23 insertions(+), 10 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 053ad00fb9..48671220a2 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -193,7 +193,12 @@ [(struct toplevel (depth pos const? set-const?)) (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) ids) - ,(decompile-expr rhs globs stack closed))] + ,(if (inline-variant? rhs) + `(begin + ,(list 'quote '%%inline-variant%%) + ,(decompile-expr (inline-variant-inline rhs) globs stack closed) + ,(decompile-expr (inline-variant-direct rhs) globs stack closed)) + (decompile-expr rhs globs stack closed)))] [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 22f5d5b95e..bfa9deb811 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -168,10 +168,10 @@ (define apply-values-type-num 24) (define case-lambda-sequence-type-num 25) (define module-type-num 26) -(define variable-type-num 34) -(define top-type-num 99) -(define prefix-type-num 112) -(define free-id-info-type-num 161) +(define inline-variants-type-num 27) +(define variable-type-num 35) +(define prefix-type-num 113) +(define free-id-info-type-num 162) (define-syntax define-enum (syntax-rules () diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 5f47e9cc54..0f8ecde12e 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -329,6 +329,9 @@ (define (read-module-wrap v) v) +(define (read-inline-variant v) + (make-inline-variant (car v) (cdr v))) + ;; ---------------------------------------- ;; Unmarshal dispatch for various types @@ -355,10 +358,11 @@ [(24) 'apply-values-type] [(25) 'case-lambda-sequence-type] [(26) 'module-type] - [(34) 'variable-type] - [(35) 'module-variable-type] - [(112) 'resolve-prefix-type] - [(161) 'free-id-info-type] + [(27) 'inline-variant-type] + [(35) 'variable-type] + [(36) 'module-variable-type] + [(113) 'resolve-prefix-type] + [(162) 'free-id-info-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers @@ -378,6 +382,7 @@ (cons 'case-lambda-sequence-type read-case-lambda) (cons 'begin0-sequence-type read-begin0) (cons 'module-type read-module) + (cons 'inline-variant-type read-inline-variant) (cons 'resolve-prefix-type read-resolve-prefix) (cons 'free-id-info-type read-free-id-info) (cons 'define-values-type read-define-values) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index d1ed02537d..971e7b06c1 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -94,9 +94,12 @@ [max-let-depth exact-nonnegative-integer?] [dummy (or/c toplevel? #f)])) +(define-form-struct (inline-variant form) ([direct expr?] + [inline expr?])) + ;; Definitions (top level or within module): (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] - [rhs (or/c expr? seq? any/c)])) + [rhs (or/c expr? seq? inline-variant? any/c)])) (define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] [rhs (or/c expr? seq? any/c)] [prefix prefix?] From 1963cc91b7a35b4a7818353303983bc0619c336c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Dec 2011 06:15:58 -0700 Subject: [PATCH 239/466] fix demod for inline-variant original commit: 788e8bb5f46be78e82772f98e7b3e766c28dfe2d --- collects/compiler/demodularizer/gc-toplevels.rkt | 2 ++ collects/compiler/demodularizer/update-toplevels.rkt | 2 ++ 2 files changed, 4 insertions(+) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index f212b66081..aa6b780389 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -66,6 +66,8 @@ (error 'build-graph "Doesn't handle syntax")] [(? seq-for-syntax?) (error 'build-graph "Doesn't handle syntax")] + [(struct inline-variant (direct inline)) + (build-graph! lhs direct)] [(struct req (reqs dummy)) (build-graph! lhs dummy)] [(? mod?) diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 15584bb5d3..3cc4ef9e14 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -12,6 +12,8 @@ (error 'increment "Doesn't handle syntax")] [(? seq-for-syntax?) (error 'increment "Doesn't handle syntax")] + [(struct inline-variant (direct inline)) + (update direct)] [(struct req (reqs dummy)) (make-req reqs (update dummy))] [(? mod?) From cd5e01e03cdf1f6e62a40f513f3ddee6fd0252f9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 13 Dec 2011 06:13:02 -0700 Subject: [PATCH 240/466] fix `raco make --no-deps' original commit: b87a7c0ec9849e0fd3807bfd8750b783f9553a59 --- collects/compiler/commands/make.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 56f8ebc1e2..4bcc7d8294 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -47,7 +47,6 @@ ,(if (assume-primitives) '(void) '(namespace-require/copy 'scheme)) - (require compiler/cffi) ,@(map (lambda (s) `(load ,s)) (prefixes)) (void))]) ((compile-zos prefix #:verbose? (verbose)) From f751553b482bdad7e89509dcbe208102f384df86 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Jan 2012 06:59:13 -0700 Subject: [PATCH 241/466] document `raco make' flags; add `--disable-constant' flag original commit: 6b6d281deebeef086631dc9ea77924786b6c16ab --- collects/compiler/commands/make.rkt | 44 ++++++++++++++++++----------- 1 file changed, 28 insertions(+), 16 deletions(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 4bcc7d8294..622353ac7b 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -12,6 +12,7 @@ (define disable-inlining (make-parameter #f)) (define disable-deps (make-parameter #f)) +(define disable-const (make-parameter #f)) (define prefixes (make-parameter null)) (define assume-primitives (make-parameter #t)) (define worker-count (make-parameter 1)) @@ -22,8 +23,16 @@ (command-line #:program (short-program+command-name) #:once-each + [("-j") n "Compile with up to tasks in parallel" + (let ([num (string->number n)]) + (unless num (raise-user-error (format "~a: bad count for -j: ~s" + (short-program+command-name) + n))) + (worker-count num))] [("--disable-inline") "Disable procedure inlining during compilation" (disable-inlining #t)] + [("--disable-constant") "Disable enforcement of module constants" + (disable-const #t)] [("--no-deps") "Compile immediate files without updating dependencies" (disable-deps #t)] [("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps" @@ -32,7 +41,6 @@ (assume-primitives #f)] [("-v") "Verbose mode" (verbose #t)] - [("-j") wc "Parallel job count" (worker-count (string->number wc))] [("--vv") "Very verbose mode" (verbose #t) (very-verbose #t)] @@ -74,7 +82,9 @@ (when (verbose) (printf "\"~a\":\n" file)) (parameterize ([compile-context-preservation-enabled - (disable-inlining)]) + (disable-inlining)] + [compile-enforce-module-constants + (not (disable-const))]) (managed-compile-zo file)) (let ([dest (append-zo-suffix (let-values ([(base name dir?) (split-path file)]) @@ -85,18 +95,20 @@ (if did-one? "output to" "already up-to-date at") dest)))))))] ;; Parallel make: - [else (parallel-compile-files source-files #:worker-count (worker-count) + [else + (parallel-compile-files + source-files + #:worker-count (worker-count) #:handler (lambda (type work msg out err) - (match type - ['done (when (verbose) (printf " Made ~a\n" work))] - ['output (printf " Output from: ~a\n~a~a" work out err)] - [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])) - #:options - (let ([cons-if-true (lambda (bool carv cdrv) - (if bool - (cons carv cdrv) - cdrv))]) - (cons-if-true - (very-verbose) - 'very-verbose - (cons-if-true (disable-inlining) 'disable-inlining null))))]) + (match type + ['done (when (verbose) (printf " Made ~a\n" work))] + ['output (printf " Output from: ~a\n~a~a" work out err)] + [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])) + #:options (let ([cons-if-true (lambda (bool carv cdrv) + (if bool + (cons carv cdrv) + cdrv))]) + (cons-if-true + (very-verbose) + 'very-verbose + (cons-if-true (disable-inlining) 'disable-inlining null))))]) From aae4950f024cc8ead85104a67c1fad8723a25047 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Jan 2012 07:53:45 -0700 Subject: [PATCH 242/466] fix `raco ctool --c-mods' for `racket' Merge to 5.2.1 original commit: 6c4cd0e9c249b502827398f597dd49b2f4ac8df6 --- collects/tests/racket/ctool.rkt | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 collects/tests/racket/ctool.rkt diff --git a/collects/tests/racket/ctool.rkt b/collects/tests/racket/ctool.rkt new file mode 100644 index 0000000000..32c2e36907 --- /dev/null +++ b/collects/tests/racket/ctool.rkt @@ -0,0 +1,19 @@ +#lang racket +(require setup/dirs) + +(define raco (build-path (find-console-bin-dir) + (if (eq? (system-type) 'windows) + "raco.exe" + "raco"))) + +(define tmp (make-temporary-file)) + +(system* raco + "ctool" + "--3m" + "--c-mods" + tmp + "++lib" + "racket") + +(delete-file tmp) From 90583ce5725fc81c2916543d0331b3ac81769792 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Jan 2012 13:12:38 -0700 Subject: [PATCH 243/466] adjust `raco ctool --c-mods' and related to work with places That is, the generated declare_modules() function registers the module-declaration code so that it is run in any new place, too. Merge to 5.2.1 original commit: 481e0614401ec0b3269a4e258cd9966de7775dce --- collects/compiler/zo-parse.rkt | 2 +- collects/tests/racket/embed-place.rkt | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) create mode 100644 collects/tests/racket/embed-place.rkt diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 0f8ecde12e..9a61c7f2af 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1061,7 +1061,7 @@ (define rst-start (file-position port)) (file-position port (+ rst-start size*)) - + (unless (eof-object? (read-byte port)) (error 'zo-parse "File too big")) diff --git a/collects/tests/racket/embed-place.rkt b/collects/tests/racket/embed-place.rkt new file mode 100644 index 0000000000..46e33a7483 --- /dev/null +++ b/collects/tests/racket/embed-place.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(require racket/place) + +(provide go) + +(define (go ch) + (place-channel-put ch 42)) From ee5fdf37715f9c09bb4ac3797850c439d5eed1aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Feb 2012 13:59:33 -0700 Subject: [PATCH 244/466] change `raco demod' test to write to temporary drectory Also add `-o' option to `raco demod'. original commit: 577f38f649fe5347350b33d4341a1023b900b5e5 --- collects/compiler/demodularizer/batch.rkt | 26 ++++++++++++------- .../compiler/demodularizer/demod-test.rkt | 13 ++++++---- 2 files changed, 25 insertions(+), 14 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 9846a958b8..37645548b6 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -50,9 +50,10 @@ Here's the idea: "replace-modidx.rkt" compiler/decompile compiler/zo-marshal - racket/set) + racket/set + raco/command-name) -(define (main file-to-batch) +(define (main file-to-batch output-file) (define-values (base name dir?) (split-path file-to-batch)) (when (or (eq? base #f) dir?) (error 'batch "Cannot run on directory")) @@ -62,7 +63,9 @@ Here's the idea: (log-info "Compiling module") (void (system* (find-executable-path "raco") "make" file-to-batch)) - (define merged-zo-path (path-add-suffix file-to-batch #"_merged.zo")) + (define merged-zo-path + (or output-file + (path-add-suffix file-to-batch #"_merged.zo"))) ;; Transformations (define path-cache (make-hash)) @@ -105,9 +108,14 @@ Here's the idea: (zo-marshal-to batch-mod (current-output-port))) #:exists 'replace))) -(command-line #:program "batch" - #:multi - [("-e" "--exclude-modules") mod - "Exclude a module from being batched" - (current-excluded-modules (set-add (current-excluded-modules) mod))] - #:args (filename) (main filename)) + +(let () + (define output-file (make-parameter #f)) + (command-line #:program (short-program+command-name) + #:multi + [("-e" "--exclude-modules") path "Exclude from flattening" + (current-excluded-modules (set-add (current-excluded-modules) path))] + [("-o") dest-filename "Write output as " + (output-file (string->path dest-filename))] + #:args (filename) + (main filename (output-file)))) diff --git a/collects/tests/compiler/demodularizer/demod-test.rkt b/collects/tests/compiler/demodularizer/demod-test.rkt index ae13457942..5d88fbc82a 100644 --- a/collects/tests/compiler/demodularizer/demod-test.rkt +++ b/collects/tests/compiler/demodularizer/demod-test.rkt @@ -16,13 +16,16 @@ (define-values (modular-output modular-error) (capture-output (find-executable-path "racket") filename)) + (define demod-filename + (let-values ([(base filename dir?) (split-path filename)]) + (path->string + (build-path + (find-system-path 'temp-dir) + (path-add-suffix filename #"_merged.zo"))))) + ; demodularize (parameterize ([current-input-port (open-input-string "")]) - (system* (find-executable-path "raco") "demod" filename)) - - (define demod-filename - (path->string - (path-add-suffix filename #"_merged.zo"))) + (system* (find-executable-path "raco") "demod" "-o" demod-filename filename)) ; run whole program (define-values (whole-output whole-error) From 02d466aec0ec2d9632049a9a4e3d44f354932dd1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 13 Feb 2012 14:30:30 -0700 Subject: [PATCH 245/466] add `--launcher'/`-l' flag to `raco exe' to create launchers This addition triggered several other changes: * -k for a Mac OS X embedding is now relative to the __PLTSCHEME segment (which means that executables won't break if you strip them, for example) * the command-line no longer has a limited size for Mac OS X launchers and embedding executables * Mac OS X GUI and Windows launchers record the creation-time collection path, unless they are created as "relative" launchers original commit: 2c479683d14c9764475f632151dc59d0bac3093a --- collects/compiler/commands/exe.rkt | 58 ++++++++++++++++++------------ collects/tests/racket/embed.rktl | 43 +++++++++++++++++----- 2 files changed, 71 insertions(+), 30 deletions(-) diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index 28d53e2ace..0ac336f9a5 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -10,6 +10,7 @@ (define gui (make-parameter #f)) (define 3m (make-parameter #t)) +(define launcher (make-parameter #f)) (define exe-output (make-parameter #f)) (define exe-embedded-flags (make-parameter '("-U" "--"))) @@ -26,6 +27,8 @@ (exe-output file)] [("--gui") "Generate GUI executable" (gui #t)] + [("-l" "--launcher") "Generate a launcher" + (launcher #t)] [("--collects-path") path "Set as main collects for executable" (exe-embedded-collects-path path)] [("--collects-dest") dir "Write collection code to " @@ -70,27 +73,38 @@ (extract-base-filename/ss source-file (string->symbol (short-program+command-name)))) (gui))]) - (mzc:create-embedding-executable - dest - #:mred? (gui) - #:variant (if (3m) '3m 'cgc) - #:verbose? (very-verbose) - #:modules (cons `(#%mzc: (file ,source-file)) - (map (lambda (l) `(#t (lib ,l))) - (exe-embedded-libraries))) - #:configure-via-first-module? #t - #:literal-expression - (parameterize ([current-namespace (make-base-namespace)]) - (compile - `(namespace-require - '',(string->symbol - (format "#%mzc:~a" - (let-values ([(base name dir?) - (split-path source-file)]) - (path->bytes (path-replace-suffix name #"")))))))) - #:cmdline (exe-embedded-flags) - #:collects-path (exe-embedded-collects-path) - #:collects-dest (exe-embedded-collects-dest) - #:aux (exe-aux)) + (cond + [(launcher) + (parameterize ([current-launcher-variant (if (3m) '3m 'cgc)]) + ((if (gui) + make-gracket-launcher + make-racket-launcher) + (append (list "-t" (path->string (path->complete-path source-file))) + (exe-embedded-flags)) + dest + (exe-aux)))] + [else + (mzc:create-embedding-executable + dest + #:mred? (gui) + #:variant (if (3m) '3m 'cgc) + #:verbose? (very-verbose) + #:modules (cons `(#%mzc: (file ,source-file)) + (map (lambda (l) `(#t (lib ,l))) + (exe-embedded-libraries))) + #:configure-via-first-module? #t + #:literal-expression + (parameterize ([current-namespace (make-base-namespace)]) + (compile + `(namespace-require + '',(string->symbol + (format "#%mzc:~a" + (let-values ([(base name dir?) + (split-path source-file)]) + (path->bytes (path-replace-suffix name #"")))))))) + #:cmdline (exe-embedded-flags) + #:collects-path (exe-embedded-collects-path) + #:collects-dest (exe-embedded-collects-dest) + #:aux (exe-aux))]) (when (verbose) (printf " [output to \"~a\"]\n" dest))) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index be92fb8b7b..79e882b036 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -6,6 +6,7 @@ (require compiler/embed mzlib/file mzlib/process + launcher compiler/distribute) (define (mk-dest-bin mred?) @@ -67,12 +68,9 @@ (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (read-string 5000))))) -(define try-exe - (case-lambda - [(exe expect mred?) - (try-exe exe expect mred? void)] - [(exe expect mred? dist-hook . collects) - (try-one-exe exe expect mred?) +(define (try-exe exe expect mred? [dist-hook void] #:dist? [dist? #t] . collects) + (try-one-exe exe expect mred?) + (when dist? ;; Build a distirbution directory, and try that, too: (printf " ... from distribution ...\n") (when (directory-exists? dist-dir) @@ -84,7 +82,7 @@ dist-mred-exe dist-mz-exe)) expect mred?) - (delete-directory/files dist-dir)])) + (delete-directory/files dist-dir))) (define (base-compile e) (parameterize ([current-namespace (make-base-namespace)]) @@ -109,6 +107,13 @@ `(,(flags "l") ,(string-append "tests/racket/" filename))) (try-exe dest expect mred?) + ;; As a launcher: + (prepare dest filename) + ((if mred? make-gracket-launcher make-racket-launcher) + (list "-l" (string-append "tests/racket/" filename)) + dest) + (try-exe dest expect mred? #:dist? #f) + ;; Try explicit prefix: (printf ">>>explicit prefix\n") (let ([w/prefix @@ -250,16 +255,38 @@ `("-l" "tests/racket/embed-me5.rkt")) (try-exe mr-dest "This is 5: #\n" #t))) -;; Try the mzc interface: +;; Try the raco interface: (require setup/dirs mzlib/file) (define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) "mzc.exe" "mzc"))) +(define raco (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) + "raco.exe" + "raco"))) (define (mzc-tests mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) + ;; raco exe + (system* raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) + (try-exe (mk-dest mred?) "This is 1\n" mred?) + + ;;raco exe --launcher + (system* raco + "exe" + "--launcher" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) + (try-exe (mk-dest mred?) "This is 1\n" mred? #:dist? #f) + + ;; the rest use mzc... + (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) From a0837b2453743ca3b2fb537a4a26c58eb3ab45b6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Mar 2012 14:47:12 -0700 Subject: [PATCH 246/466] first cut at submodules original commit: 3d69dfab863c116439ce5b747dbc69852db74938 --- collects/compiler/decompile.rkt | 23 ++-- collects/compiler/demodularizer/merge.rkt | 3 +- collects/compiler/demodularizer/nodep.rkt | 3 +- collects/compiler/zo-marshal.rkt | 131 +++++++++++++++++++++- collects/compiler/zo-parse.rkt | 119 ++++++++++++++++++-- collects/compiler/zo-structs.rkt | 6 +- collects/tests/compiler/zo.rkt | 39 ++++++- collects/tests/racket/embed-me15-one.rkt | 13 +++ collects/tests/racket/embed-me15.rkt | 5 + collects/tests/racket/embed.rktl | 1 + 10 files changed, 312 insertions(+), 31 deletions(-) create mode 100644 collects/tests/racket/embed-me15-one.rkt create mode 100644 collects/tests/racket/embed-me15.rkt diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 48671220a2..502987e326 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -1,8 +1,9 @@ -#lang scheme/base +#lang racket/base (require compiler/zo-parse syntax/modcollapse - scheme/port - scheme/match + racket/port + racket/match + racket/list racket/set) (provide decompile) @@ -162,15 +163,17 @@ [(symbol? modidx) modidx] [else (collapse-module-path-index modidx (current-directory))])) -(define (decompile-module mod-form stack stx-ht) +(define (decompile-module mod-form orig-stack stx-ht name) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info internal-context)) + max-let-depth dummy lang-info internal-context pre-submodules post-submodules)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] - [(stack) (append '(#%modvars) stack)] + [(stack) (append '(#%modvars) orig-stack)] [(closed) (make-hasheq)]) - `(module ,name .... + `(,name ,(if (symbol? name) name (last name)) .... ,internal-context ,@defns + ,@(for/list ([submod (in-list pre-submodules)]) + (decompile-module submod orig-stack stx-ht 'module)) ,@(for/list ([b (in-list syntax-bodies)]) (let loop ([n (sub1 (car b))]) (if (zero? n) @@ -180,13 +183,15 @@ (list 'begin-for-syntax (loop (sub1 n)))))) ,@(map (lambda (form) (decompile-form form globs stack closed stx-ht)) - body)))] + body) + ,@(for/list ([submod (in-list post-submodules)]) + (decompile-module submod orig-stack stx-ht 'module*))))] [else (error 'decompile-module "huh?: ~e" mod-form)])) (define (decompile-form form globs stack closed stx-ht) (match form [(? mod?) - (decompile-module form stack stx-ht)] + (decompile-module form stack stx-ht 'module)] [(struct def-values (ids rhs)) `(define-values ,(map (lambda (tl) (match tl diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 6e57f5962c..aff21cee1b 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -109,7 +109,8 @@ (define (merge-module max-let-depth top-prefix mod-form) (match mod-form [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies - unexported mod-max-let-depth dummy lang-info internal-context)) + unexported mod-max-let-depth dummy lang-info internal-context + pre-submodules post-submodules)) (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 68cc899241..3c0ca87a25 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -113,7 +113,8 @@ (define (nodep-module mod-form phase) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies - unexported max-let-depth dummy lang-info internal-context)) + unexported max-let-depth dummy lang-info internal-context + pre-submodules post-submodules)) (define new-prefix prefix) ; Cache all the mpi paths (for-each (match-lambda diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index bfa9deb811..c2c6754cd4 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -25,6 +25,119 @@ (get-output-bytes bs)) (define (zo-marshal-to top outp) + (if (and (mod? (compilation-top-code top)) + (or (pair? (mod-pre-submodules (compilation-top-code top))) + (pair? (mod-post-submodules (compilation-top-code top))))) + ;; module directory and submodules: + (zo-marshal-modules-to top outp) + ;; single module or other: + (zo-marshal-top-to top outp))) + +(define (zo-marshal-modules-to top outp) + ;; Write the compiled form header + (write-bytes #"#~" outp) + ;; Write the version: + (define version-bs (string->bytes/latin-1 (version))) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + + (write-byte (char->integer #\D) outp) + + (struct mod-bytes (code-bstr name-bstr offset)) + ;; bytestring encodings of the modules and module names + ;; --- in the order that they must be written: + (define pre-mod-bytess + (reverse + (let loop ([m (compilation-top-code top)] [pre-accum null]) + (define (encode-module-name name) + (if (symbol? name) + #"" + (apply bytes-append + (for/list ([sym (in-list (cdr name))]) + (define b (string->bytes/utf-8 (symbol->string sym))) + (define len (bytes-length b)) + (bytes-append (if (len . < . 255) + (bytes len) + (bytes-append + (bytes 255) + (integer->integer-bytes len 4 #f #f))) + b))))) + (define accum + (let iloop ([accum pre-accum] [subm (mod-pre-submodules m)]) + (if (null? subm) + accum + (iloop (loop (car subm) accum) (cdr subm))))) + (define o (open-output-bytes)) + (zo-marshal-top-to (struct-copy compilation-top top + [code (struct-copy mod m + [pre-submodules null] + [post-submodules null])]) + o) + (define new-accum + (cons (mod-bytes (get-output-bytes o) + (encode-module-name (mod-name m)) + 0) + accum)) + (let iloop ([accum new-accum] [subm (mod-post-submodules m)]) + (if (null? subm) + accum + (iloop (loop (car subm) accum) (cdr subm))))))) + (write-bytes (int->bytes (length pre-mod-bytess)) outp) + ;; Size of btree: + (define btree-size + (+ 8 + (string-length (version)) + (apply + (for/list ([mb (in-list pre-mod-bytess)]) + (+ (bytes-length (mod-bytes-name-bstr mb)) + 20))))) + ;; Add offsets to mod-bytess: + (define mod-bytess (let loop ([offset btree-size] [mod-bytess pre-mod-bytess]) + (if (null? mod-bytess) + null + (let ([mb (car mod-bytess)]) + (cons (mod-bytes (mod-bytes-code-bstr mb) + (mod-bytes-name-bstr mb) + offset) + (loop (+ offset + (bytes-length (mod-bytes-code-bstr mb))) + (cdr mod-bytess))))))) + ;; Sort by name for btree order: + (define sorted-mod-bytess + (list->vector (sort mod-bytess bytesbytes name-len) outp) + (write-bytes (mod-bytes-name-bstr mb) outp) + (write-bytes (int->bytes (mod-bytes-offset mb)) outp) + (write-bytes (int->bytes (bytes-length (mod-bytes-code-bstr mb))) outp) + (define left-pos (+ pos name-len 20)) + (write-bytes (int->bytes (if (= lo mid) + 0 + left-pos)) + outp) + (write-bytes (int->bytes (if (= (add1 mid) hi) + 0 + (vector-ref right-offsets mid))) + outp) + (define right-pos (if (= lo mid) + left-pos + (loop lo mid left-pos))) + (vector-set! right-offsets mid right-pos) + (if (= (add1 mid) hi) + right-pos + (loop (add1 mid) hi right-pos)))) + (write-btree void) ; to fill `right-offsets' + (write-btree write-bytes) ; to actually write the btree + ;; write modules: + (for ([mb (in-list mod-bytess)]) + (write-bytes (mod-bytes-code-bstr mb) outp))) + +(define (zo-marshal-top-to top outp) ; XXX: wraps were encoded in traverse, now needs to be handled when writing (define wrapped (make-hash)) @@ -127,6 +240,8 @@ (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) + (write-byte (char->integer #\T) outp) + ; Write empty hash code (write-bytes (make-bytes 20 0) outp) @@ -821,9 +936,14 @@ [else (error 'out-anything "~s" (current-type-trace))]))))) (define (out-module mod-form out) + (out-marshaled module-type-num + (convert-module mod-form) + out)) + +(define (convert-module mod-form) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info internal-context)) + max-let-depth dummy lang-info internal-context pre-submodules post-submodules)) (let* ([lookup-req (lambda (phase) (let ([a (assq phase requires)]) (if a @@ -917,12 +1037,13 @@ [l (cons internal-context l)] ; module->namespace syntax [l (list* #f #f l)] ; obsolete `functional?' info [l (cons lang-info l)] ; lang-info + [l (cons (map convert-module post-submodules) l)] + [l (cons (map convert-module pre-submodules) l)] [l (cons self-modidx l)] [l (cons srcname l)] - [l (cons name l)]) - (out-marshaled module-type-num - l - out))])) + [l (cons (if (pair? name) (car name) name) l)] + [l (cons (if (pair? name) (cdr name) null) l)]) + l)])) (define (lookup-encoded-wrapped w out) (hash-ref! (out-encoded-wraps out) w diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 9a61c7f2af..3200cecf98 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -247,17 +247,25 @@ (define (read-module v) (match v - [`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional? - ,rename ,max-let-depth ,dummy - ,prefix ,num-phases - ,provide-phase-count . ,rest) + [`(,submod-path + ,name ,srcname ,self-modidx + ,pre-submods ,post-submods + ,lang-info ,functional? ,et-functional? + ,rename ,max-let-depth ,dummy + ,prefix ,num-phases + ,provide-phase-count . ,rest) (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)] [(bodies rest-module) (values (take rest-module num-phases) (drop rest-module num-phases))]) (match rest-module [`(,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) - (make-mod name srcname self-modidx + (make-mod (if (null? submod-path) + name + (if (symbol? name) + (cons name submod-path) + (cons (car name) submod-path))) + srcname self-modidx prefix ;; provides: (for/list ([l (in-list phase-data)]) @@ -325,7 +333,9 @@ max-let-depth dummy lang-info - rename)]))])) + rename + (map read-module pre-submods) + (map read-module post-submods))]))])) (define (read-module-wrap v) v) @@ -1029,15 +1039,101 @@ (set-cport-pos! cp save-pos))) (placeholder-get ph)))) -;; path -> bytes -;; implementes read.c:read_compiled -(define (zo-parse [port (current-input-port)]) +(define (read-prefix port) ;; skip the "#~" (unless (equal? #"#~" (read-bytes 2 port)) (error 'zo-parse "not a bytecode stream")) (define version (read-bytes (min 63 (read-byte port)) port)) + (read-char port)) + +;; path -> bytes +;; implementes read.c:read_compiled +(define (zo-parse [port (current-input-port)]) + (define init-pos (file-position port)) + + (define mode (read-prefix port)) + + (case mode + [(#\T) (zo-parse-top port)] + [(#\D) + (struct mod-info (name start len)) + (define mod-infos + (sort + (for/list ([i (in-range (read-simple-number port))]) + (define size (read-simple-number port)) + (define name (read-bytes size port)) + (define start (read-simple-number port)) + (define len (read-simple-number port)) + (define left (read-simple-number port)) + (define right (read-simple-number port)) + (define name-p (open-input-bytes name)) + (mod-info (let loop () + (define c (read-byte name-p)) + (if (eof-object? c) + null + (cons (string->symbol + (bytes->string/utf-8 (read-bytes (if (= c 255) + (read-simple-number port) + c) + name-p))) + (loop)))) + start + len)) + < + #:key mod-info-start)) + (define tops + (for/list ([mod-info (in-list mod-infos)]) + (define pos (file-position port)) + (unless (= (- pos init-pos) (mod-info-start mod-info)) + (error 'zo-parse + "next module expected at ~a, currently at ~a" + (+ init-pos (mod-info-start mod-info)) pos)) + (unless (eq? (read-prefix port) #\T) + (error 'zo-parse "expected a module")) + (define top (zo-parse-top port #f)) + (define m (compilation-top-code top)) + (unless (mod? m) + (error 'zo-parse "expected a module")) + (unless (equal? (mod-info-name mod-info) + (if (symbol? (mod-name m)) + '() + (cdr (mod-name m)))) + (error 'zo-parse "module name mismatch")) + top)) + (define avail (for/hash ([mod-info (in-list mod-infos)] + [top (in-list tops)]) + (values (mod-info-name mod-info) top))) + (unless (hash-ref avail '() #f) + (error 'zo-parse "no root module in directory")) + (define-values (pre-subs post-subs seen) + (for/fold ([pre-subs (hash)] [post-subs (hash)] [seen (hash)]) ([mod-info (in-list mod-infos)]) + (if (null? (mod-info-name mod-info)) + (values pre-subs post-subs (hash-set seen '() #t)) + (let () + (define name (mod-info-name mod-info)) + (define prefix (take name (sub1 (length name)))) + (unless (hash-ref avail prefix #f) + (error 'zo-parse "no parent module for ~s" name)) + (define (add subs) + (hash-set subs prefix (cons name (hash-ref subs prefix '())))) + (define new-seen (hash-set seen name #t)) + (if (hash-ref seen prefix #f) + (values pre-subs (add post-subs) new-seen) + (values (add pre-subs) post-subs new-seen)))))) + (define (get-all prefix) + (struct-copy mod + (compilation-top-code (hash-ref avail prefix)) + [pre-submodules (map get-all (reverse (hash-ref pre-subs prefix '())))] + [post-submodules (map get-all (reverse (hash-ref post-subs prefix '())))])) + (struct-copy compilation-top (hash-ref avail '()) + [code (get-all '())])] + [else + (error 'zo-parse "bad file format specifier")])) + +(define (zo-parse-top [port (current-input-port)] [check-end? #t]) + ;; Skip module hash code (read-bytes 20 port) @@ -1062,8 +1158,9 @@ (file-position port (+ rst-start size*)) - (unless (eof-object? (read-byte port)) - (error 'zo-parse "File too big")) + (when check-end? + (unless (eof-object? (read-byte port)) + (error 'zo-parse "File too big"))) (define nr (make-not-ready)) (define symtab diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 971e7b06c1..448d43d611 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -106,7 +106,7 @@ [max-let-depth exact-nonnegative-integer?] [dummy (or/c toplevel? #f)])) -(define-form-struct (mod form) ([name symbol?] +(define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))] [srcname symbol?] [self-modidx module-path-index?] [prefix prefix?] @@ -124,7 +124,9 @@ [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx?)])) + [internal-context (or/c #f #t stx?)] + [pre-submodules (listof mod?)] + [post-submodules (listof mod?)])) (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] [flags (listof (or/c 'preserves-marks 'is-method 'single-result diff --git a/collects/tests/compiler/zo.rkt b/collects/tests/compiler/zo.rkt index 84b3bd6951..5c0b885223 100644 --- a/collects/tests/compiler/zo.rkt +++ b/collects/tests/compiler/zo.rkt @@ -21,6 +21,42 @@ (define s 10) (provide t (protect-out s)))) +(define ex-mod3 + '(module m racket/base + (module* a racket/base + (provide a) + (define a 1) + (module* a+ racket/base + (define a+ 1.1))) + (module* b racket/base + (require (submod "." ".." a)) + (provide b) + (define b (+ a 1))))) + +(define ex-mod4 + '(module m racket/base + (module a racket/base + (provide a) + (define a 1) + (module a+ racket/base + (define a+ 1.1))) + (module b racket/base + (require (submod "." ".." a)) + (provide b) + (define b (+ a 1))))) + +(define ex-mod5 + '(module m racket/base + (module a racket/base + (provide a) + (define a 1) + (module* a+ racket/base + (define a+ 1.1))) + (module* b racket/base + (require (submod "." ".." a)) + (provide b) + (define b (+ a 1))))) + (define (check ex-mod) (let ([c (parameterize ([current-namespace (make-base-namespace)]) (compile ex-mod))]) @@ -36,5 +72,4 @@ (unless (equal? (to-string p) (to-string p2)) (error 'zo "failed on example: ~e" ex-mod)))))))) -(check ex-mod1) -(check ex-mod2) +(for-each check (list ex-mod1 ex-mod2 ex-mod3 ex-mod4 ex-mod5)) diff --git a/collects/tests/racket/embed-me15-one.rkt b/collects/tests/racket/embed-me15-one.rkt new file mode 100644 index 0000000000..c1df6af344 --- /dev/null +++ b/collects/tests/racket/embed-me15-one.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(define two 2) +(provide two) + +(module* one #f + (require (submod "." ".." three)) + (define one 1) + (provide one two three)) + +(module three racket/base + (define three 3) + (provide three)) + diff --git a/collects/tests/racket/embed-me15.rkt b/collects/tests/racket/embed-me15.rkt new file mode 100644 index 0000000000..b6c4f00c57 --- /dev/null +++ b/collects/tests/racket/embed-me15.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require (submod "embed-me15-one.rkt" one)) +(printf "This is ~a.\n" (+ 9 one two three)) + + diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 79e882b036..7e6254f467 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -223,6 +223,7 @@ (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) (one-mz-test "embed-me13.rkt" "This is 14\n" #f) (one-mz-test "embed-me14.rkt" "This is 14\n" #f) + (one-mz-test "embed-me15.rkt" "This is 15\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode") From f2dbacc73f4befd1cf71b87b8f85961bcc7bc41f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 9 Mar 2012 10:22:50 -0700 Subject: [PATCH 247/466] `raco exe' uses a `main' submodule, if any original commit: 85802f45f2ff1c3cf1701d30eb0899815a16e280 --- collects/compiler/commands/exe.rkt | 18 +++++++++++------- collects/tests/racket/embed-me15.rkt | 6 +++--- collects/tests/racket/embed-me16.rkt | 7 +++++++ collects/tests/racket/embed.rktl | 10 +++++++++- 4 files changed, 30 insertions(+), 11 deletions(-) create mode 100644 collects/tests/racket/embed-me16.rkt diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index 0ac336f9a5..b18f17dabc 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -89,19 +89,23 @@ #:mred? (gui) #:variant (if (3m) '3m 'cgc) #:verbose? (very-verbose) - #:modules (cons `(#%mzc: (file ,source-file)) + #:modules (cons `(#%mzc: (file ,source-file) (main)) (map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries))) #:configure-via-first-module? #t #:literal-expression (parameterize ([current-namespace (make-base-namespace)]) + (define mod-sym (string->symbol + (format "#%mzc:~a" + (let-values ([(base name dir?) + (split-path source-file)]) + (path->bytes (path-replace-suffix name #"")))))) + (define main-sym (string->symbol (format "~a(main)" mod-sym))) (compile - `(namespace-require - '',(string->symbol - (format "#%mzc:~a" - (let-values ([(base name dir?) - (split-path source-file)]) - (path->bytes (path-replace-suffix name #"")))))))) + `(begin + (namespace-require '',mod-sym) + (when (module-declared? '',main-sym) + (dynamic-require '',main-sym #f))))) #:cmdline (exe-embedded-flags) #:collects-path (exe-embedded-collects-path) #:collects-dest (exe-embedded-collects-dest) diff --git a/collects/tests/racket/embed-me15.rkt b/collects/tests/racket/embed-me15.rkt index b6c4f00c57..d8107232ec 100644 --- a/collects/tests/racket/embed-me15.rkt +++ b/collects/tests/racket/embed-me15.rkt @@ -1,5 +1,5 @@ #lang racket/base (require (submod "embed-me15-one.rkt" one)) -(printf "This is ~a.\n" (+ 9 one two three)) - - +(with-output-to-file "stdout" + (lambda () (printf "This is ~a.\n" (+ 9 one two three))) + #:exists 'append) diff --git a/collects/tests/racket/embed-me16.rkt b/collects/tests/racket/embed-me16.rkt new file mode 100644 index 0000000000..3b109f622f --- /dev/null +++ b/collects/tests/racket/embed-me16.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +;; a `main' submodule: +(module main racket/base + (with-output-to-file "stdout" + (lambda () (printf "This is 16.\n")) + #:exists 'append)) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 7e6254f467..1ccbc1bafd 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -223,7 +223,7 @@ (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) (one-mz-test "embed-me13.rkt" "This is 14\n" #f) (one-mz-test "embed-me14.rkt" "This is 14\n" #f) - (one-mz-test "embed-me15.rkt" "This is 15\n" #f) + (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -277,6 +277,14 @@ (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) + ;; raco exe on a module with a `main' submodule + (system* raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "racket") "embed-me16.rkt"))) + (try-exe (mk-dest mred?) "This is 16.\n" mred?) + ;;raco exe --launcher (system* raco "exe" From 9741ae6d98a7625c047cac36a37082132c84788c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 9 Mar 2012 15:54:07 -0700 Subject: [PATCH 248/466] Adding module**, when-testing, and raco test original commit: b73444a0f3fff7ec0d3a0d22511b3098238776e5 --- collects/compiler/commands/info.rkt | 1 + collects/compiler/commands/test.rkt | 28 ++++++++++++++++++++++++++++ collects/tests/compiler/test/a.rkt | 4 ++++ collects/tests/compiler/test/b.rkt | 4 ++++ collects/tests/compiler/test/d/c.rkt | 4 ++++ collects/tests/compiler/test/d/d.rkt | 1 + 6 files changed, 42 insertions(+) create mode 100644 collects/compiler/commands/test.rkt create mode 100644 collects/tests/compiler/test/a.rkt create mode 100644 collects/tests/compiler/test/b.rkt create mode 100644 collects/tests/compiler/test/d/c.rkt create mode 100644 collects/tests/compiler/test/d/d.rkt diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index e20ae53b7d..7d97e9d09c 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -6,6 +6,7 @@ ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" 10) ("decompile" compiler/commands/decompile "decompile bytecode" #f) + ("test" compiler/commands/test "run all tests associated with a set of paths" #f) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt new file mode 100644 index 0000000000..52a92bec9e --- /dev/null +++ b/collects/compiler/commands/test.rkt @@ -0,0 +1,28 @@ +#lang racket/base +(require racket/cmdline + racket/match + racket/path + raco/command-name) + +(define do-test + (match-lambda + [(? string? s) + (do-test (string->path s))] + [(? path? p) + (cond + [(directory-exists? p) + (for-each + (λ (dp) + (do-test (build-path p dp))) + (directory-list p))] + [(file-exists? p) + (define mod `(submod (file ,(path->string p)) test)) + (when (module-declared? mod #t) + (dynamic-require mod #f))] + [else + (error 'test "Given path ~e does not exist" p)])])) + +(command-line + #:program (short-program+command-name) + #:args files+directories + (for-each do-test files+directories)) diff --git a/collects/tests/compiler/test/a.rkt b/collects/tests/compiler/test/a.rkt new file mode 100644 index 0000000000..a8b4a5e6f7 --- /dev/null +++ b/collects/tests/compiler/test/a.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'dont-run) +(module test racket/base + (printf "a\n")) diff --git a/collects/tests/compiler/test/b.rkt b/collects/tests/compiler/test/b.rkt new file mode 100644 index 0000000000..dc1a6edb80 --- /dev/null +++ b/collects/tests/compiler/test/b.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'dont-run) +(module test racket/base + (printf "b\n")) diff --git a/collects/tests/compiler/test/d/c.rkt b/collects/tests/compiler/test/d/c.rkt new file mode 100644 index 0000000000..892e318617 --- /dev/null +++ b/collects/tests/compiler/test/d/c.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'dont-run) +(module test racket/base + (printf "c\n")) diff --git a/collects/tests/compiler/test/d/d.rkt b/collects/tests/compiler/test/d/d.rkt new file mode 100644 index 0000000000..7bc35af1c4 --- /dev/null +++ b/collects/tests/compiler/test/d/d.rkt @@ -0,0 +1 @@ +#lang racket/base From 98fa97ae26ca97823ea7e22d8b24f09f58cbc68a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 9 Mar 2012 19:51:42 -0700 Subject: [PATCH 249/466] racket/slice, expand raco test, remove begin-for-testing original commit: f8325776cf2bc3bd893a3a4a0ef891e919938458 --- collects/compiler/commands/test.rkt | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 52a92bec9e..14b728d24e 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -4,25 +4,41 @@ racket/path raco/command-name) +(define submodule 'test) +(define run-anyways? #f) + (define do-test (match-lambda [(? string? s) (do-test (string->path s))] [(? path? p) + (define ps (path->string p)) (cond [(directory-exists? p) (for-each (λ (dp) (do-test (build-path p dp))) (directory-list p))] - [(file-exists? p) - (define mod `(submod (file ,(path->string p)) test)) - (when (module-declared? mod #t) - (dynamic-require mod #f))] - [else + [(and (file-exists? p) + (regexp-match #rx"\\.rkt$" ps)) + (define fmod `(file ,ps)) + (define mod `(submod ,fmod ,submodule)) + (cond + [(module-declared? mod #t) + (dynamic-require mod #f)] + [(and run-anyways? (module-declared? fmod #t)) + (dynamic-require fmod #f)])] + [(not (file-exists? p)) (error 'test "Given path ~e does not exist" p)])])) (command-line #:program (short-program+command-name) + #:once-each + [("--submodule" "-s") submodule-str + "Determines which submodule to load" + (set! submodule (string->symbol submodule-str))] + [("--run-if-absent" "-r") + "When set, raco test will require the default module if the given submodule is not present." + (set! run-anyways? #t)] #:args files+directories (for-each do-test files+directories)) From 95ed87abd4e90fadf2145a7fa2532db90a3c9708 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Mar 2012 09:04:37 -0600 Subject: [PATCH 250/466] decompiler repairs related to changes for submodules original commit: 5dc08cbe03b2ae728261c132911583ca79b64e5d --- collects/compiler/decompile.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 502987e326..fdf1904256 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -163,14 +163,14 @@ [(symbol? modidx) modidx] [else (collapse-module-path-index modidx (current-directory))])) -(define (decompile-module mod-form orig-stack stx-ht name) +(define (decompile-module mod-form orig-stack stx-ht mod-name) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context pre-submodules post-submodules)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [(stack) (append '(#%modvars) orig-stack)] [(closed) (make-hasheq)]) - `(,name ,(if (symbol? name) name (last name)) .... ,internal-context + `(,mod-name ,(if (symbol? name) name (last name)) .... ,@defns ,@(for/list ([submod (in-list pre-submodules)]) (decompile-module submod orig-stack stx-ht 'module)) From 32da9b50bbe76f3299aabd1a2251a5059b0addc7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 22 Mar 2012 14:46:05 -0600 Subject: [PATCH 251/466] doc corrections and improvements related to submodules In particular, add `module+' to the Guide. original commit: 876bc6f02b05c922a853febc927e76e5dae6daa0 --- collects/compiler/commands/test.rkt | 37 ++++++++++++++--------------- 1 file changed, 18 insertions(+), 19 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 14b728d24e..d0d6c33df6 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -7,38 +7,37 @@ (define submodule 'test) (define run-anyways? #f) -(define do-test - (match-lambda - [(? string? s) - (do-test (string->path s))] - [(? path? p) - (define ps (path->string p)) - (cond +(define (do-test e [check-suffix? #f]) + (match e + [(? string? s) + (do-test (string->path s))] + [(? path? p) + (cond [(directory-exists? p) (for-each (λ (dp) - (do-test (build-path p dp))) + (do-test (build-path p dp) #t)) (directory-list p))] [(and (file-exists? p) - (regexp-match #rx"\\.rkt$" ps)) - (define fmod `(file ,ps)) - (define mod `(submod ,fmod ,submodule)) + (or (not check-suffix?) + (regexp-match #rx#"\\.rkt$" (path->bytes p)))) + (define mod `(submod ,p ,submodule)) (cond [(module-declared? mod #t) (dynamic-require mod #f)] - [(and run-anyways? (module-declared? fmod #t)) - (dynamic-require fmod #f)])] + [(and run-anyways? (module-declared? p #t)) + (dynamic-require p #f)])] [(not (file-exists? p)) (error 'test "Given path ~e does not exist" p)])])) (command-line #:program (short-program+command-name) #:once-each - [("--submodule" "-s") submodule-str - "Determines which submodule to load" - (set! submodule (string->symbol submodule-str))] + [("--submodule" "-s") name + "Runs submodule (defaults to `test')" + (set! submodule (string->symbol name))] [("--run-if-absent" "-r") - "When set, raco test will require the default module if the given submodule is not present." + "Require base module if submodule is absent" (set! run-anyways? #t)] - #:args files+directories - (for-each do-test files+directories)) + #:args file-or-directory + (for-each do-test file-or-directory)) From 6a69441d84c90182cfa98b1a5473d69b61a32868 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Mar 2012 14:36:45 -0600 Subject: [PATCH 252/466] promote `raco test'; demote `raco unpack' original commit: 96e4fa0d13b86ec6e7508b7bee163bde817c44e1 --- collects/compiler/commands/info.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 7d97e9d09c..3fb1709547 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -4,9 +4,9 @@ '(("make" compiler/commands/make "compile source to bytecode" 100) ("exe" compiler/commands/exe "create executable" 20) ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) - ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" 10) + ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" #f) ("decompile" compiler/commands/decompile "decompile bytecode" #f) - ("test" compiler/commands/test "run all tests associated with a set of paths" #f) + ("test" compiler/commands/test "run tests associated with files/directories" 15) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f) From 5868d51521b3c08224a3a9cf5ae310acdb50a7da Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Mar 2012 14:37:00 -0600 Subject: [PATCH 253/466] make `--run-if-absent' the default mode for `raco test' This convention makes it easier to deal with a set of ".rkt" files that implement tests, while a `test' module implements a `main'-like split for some of the files. original commit: 63a4414863eb69da7597a539102e020a2df8f590 --- collects/compiler/commands/test.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index d0d6c33df6..082b028536 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -5,7 +5,7 @@ raco/command-name) (define submodule 'test) -(define run-anyways? #f) +(define run-anyways? #t) (define (do-test e [check-suffix? #f]) (match e @@ -37,7 +37,10 @@ "Runs submodule (defaults to `test')" (set! submodule (string->symbol name))] [("--run-if-absent" "-r") - "Require base module if submodule is absent" + "Require module if submodule is absent (on by default)" (set! run-anyways? #t)] + [("--no-run-if-absent" "-x") + "Require nothing if submodule is absent" + (set! run-anyways? #f)] #:args file-or-directory (for-each do-test file-or-directory)) From 197004495a44c2b2c5b90429fa24d4bd4ded63f6 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Tue, 20 Mar 2012 13:26:36 -0400 Subject: [PATCH 254/466] Optimize cpt-table-lookup (Tweaked by Eli.) original commit: 8f2ea07ec5f49bba549d693718eabed354bc71c8 --- collects/compiler/zo-parse.rkt | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 3200cecf98..56c81345ed 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -446,8 +446,8 @@ r) (define small-list-max 65) -(define cpt-table - ;; The "schcpt.h" mapping +(define raw-cpt-table + ;; The "schcpt.h" mapping, earlier entries override later ones `([0 escape] [1 symbol] [2 symref] @@ -496,14 +496,15 @@ [249 small-application3] [247 255 small-application])) -(define (cpt-table-lookup i) - (for/or ([ent cpt-table]) - (match ent - [(list k sym) (and (= k i) (cons k sym))] - [(list k k* sym) - (and (<= k i) - (< i k*) - (cons k sym))]))) +;; To accelerate cpt-table lookup, we flatten out the above +;; list into a vector: +(define cpt-table (make-vector 256 #f)) +(for ([ent (in-list (reverse raw-cpt-table))]) + ;; reverse order so that early entries override later ones. + (match ent + [(list k sym) (vector-set! cpt-table k (cons k sym))] + [(list k k* sym) (for ([i (in-range k k*)]) + (vector-set! cpt-table i (cons k sym)))])) (define (read-compact-bytes port c) (begin0 @@ -782,10 +783,9 @@ (define (read-compact cp) (let loop ([need-car 0] [proper #f]) (define ch (cp-getc cp)) - (define-values (cpt-start cpt-tag) - (let ([x (cpt-table-lookup ch)]) - (unless x - (error 'read-compact "unknown code : ~a" ch)) + (define-values (cpt-start cpt-tag) + (let ([x (vector-ref cpt-table ch)]) + (unless x (error 'read-compact "unknown code : ~a" ch)) (values (car x) (cdr x)))) (define v (case cpt-tag From 4b4a17b3c647eeb22f7408079e8be2eddf75c53e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Apr 2012 07:37:30 -0600 Subject: [PATCH 255/466] fix `raco demod' for new submodule fields in zo structs original commit: 16d65ed251d515ad12d395af7e5f6ec5e81bb4c4 --- collects/compiler/demodularizer/module.rkt | 4 +++- collects/compiler/demodularizer/nodep.rkt | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 0bf82da22c..9c907a5153 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -28,7 +28,9 @@ max-let-depth (make-toplevel 0 0 #f #f) ; dummy lang-info - #t))])) + #t + empty + empty))])) (provide/contract [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)]) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 3c0ca87a25..cb717a1a2c 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -130,7 +130,8 @@ (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now (list (make-mod name srcname self-modidx new-prefix provides requires body empty - unexported max-let-depth dummy lang-info internal-context))) + unexported max-let-depth dummy lang-info internal-context + empty empty))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] [else (error 'nodep-module "huh?: ~e" mod-form)])) From 7afd70f96e4cd45b4edd7f721c386227bb46de9d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Apr 2012 08:02:50 -0600 Subject: [PATCH 256/466] fix Planet resolver for submodule tests For example, `(module-declared? '(submod (planet dyoo/bf) reader) #t)' shouldn't fail if there's no "main.rkt" to hold a `reader' submodule; it should return #f. Merge to 5.3, but updating cstartup.inc will require a manual merge. original commit: 862e1628a6abede3e5467b7820f62bcad259e4d0 --- collects/tests/racket/embed-planet-1/has-sub.rkt | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 collects/tests/racket/embed-planet-1/has-sub.rkt diff --git a/collects/tests/racket/embed-planet-1/has-sub.rkt b/collects/tests/racket/embed-planet-1/has-sub.rkt new file mode 100644 index 0000000000..e9a5a07112 --- /dev/null +++ b/collects/tests/racket/embed-planet-1/has-sub.rkt @@ -0,0 +1,3 @@ +#lang racket/base + +(module+ the-sub) From ac6210c42e52e307ba8216bee1235d1ae1763869 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Apr 2012 21:10:19 -0600 Subject: [PATCH 257/466] save modidx submodule path in bytecode form This change should have been part of 9ba663aa77a. original commit: f099eec2af7c48321b9e59c68f1083372e0e4e6c --- collects/compiler/decompile.rkt | 3 ++- collects/compiler/zo-marshal.rkt | 4 +++- collects/compiler/zo-parse.rkt | 7 ++++++- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index fdf1904256..ac8808a940 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -161,7 +161,8 @@ (define (mpi->string modidx) (cond [(symbol? modidx) modidx] - [else (collapse-module-path-index modidx (current-directory))])) + [else + (collapse-module-path-index modidx (current-directory))])) (define (decompile-module mod-form orig-stack stx-ht mod-name) (match mod-form diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index c2c6754cd4..a05194725d 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -895,7 +895,9 @@ (out-byte CPT_MODULE_INDEX out) (let-values ([(name base) (module-path-index-split v)]) (out-anything name out) - (out-anything base out))] + (out-anything base out) + (unless (or name base) + (out-anything (module-path-index-submodule v) out)))] [(stx encoded) (out-byte CPT_STX out) (out-anything encoded out)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 56c81345ed..4ddf836aab 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -840,7 +840,12 @@ (eq? cpt-tag 'let-one-unused))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] - [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))] + [(module-index) + (define name (read-compact cp)) + (define base (read-compact cp)) + (if (or name base) + (module-path-index-join name base) + (module-path-index-join #f #f (read-compact cp)))] [(module-var) (let ([mod (read-compact cp)] [var (read-compact cp)] From d0f469f166b2d2d11ce51c4a1bf037a4f210aeeb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 28 Apr 2012 05:23:18 -0400 Subject: [PATCH 258/466] Fix command-line for the demodularizer. Closes PR 12731. original commit: 16d40c3170318f8c33fdff7573c7814d1c5c9778 --- collects/compiler/demodularizer/batch.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 37645548b6..afb495a473 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -115,6 +115,7 @@ Here's the idea: #:multi [("-e" "--exclude-modules") path "Exclude from flattening" (current-excluded-modules (set-add (current-excluded-modules) path))] + #:once-each [("-o") dest-filename "Write output as " (output-file (string->path dest-filename))] #:args (filename) From ae29015ee7c70b13e8d16fed268d1170c65a47f7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 6 May 2012 12:06:00 -0400 Subject: [PATCH 259/466] A bunch of `fprintf' -> `eprintf' conversions (and a few related things). original commit: 17090fca4f19298f01d03fea419edb20f315d040 --- collects/compiler/demodularizer/util.rkt | 3 --- collects/tests/compiler/zo-test.rkt | 4 ++-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 717dee8994..1865bc133f 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -9,9 +9,6 @@ (define total-stxs (length (prefix-stxs pre))) (+ syntax-start total-stxs (if (zero? total-stxs) 0 1))) -(define (eprintf . args) - (apply fprintf (current-error-port) args)) - (struct nothing ()) (define-syntax-rule (eprintf* . args) (void)) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index 1b1279eb36..672b8677c8 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -137,9 +137,9 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (unless (and (not (care-about-nonserious?)) (not serious?)) (when (or (verbose-mode) (stop-on-first-error)) - (fprintf (current-error-port) "~a -- ~a: ~a\n" p phase exn-msg)) + (eprintf "~a -- ~a: ~a\n" p phase exn-msg)) (when (stop-on-first-error) - (stop!)))])) + (stop!)))])) (define timing-thread (thread From 5139f5e8d61ea62ed7284abcc146727638aa6e0b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 May 2012 21:17:22 -0600 Subject: [PATCH 260/466] allow #f as shift for `syntax-shift-phase-level' original commit: dbd940611eacd91eb045632a5380b14d808f9396 --- collects/compiler/zo-structs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 448d43d611..03b53d31dc 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -193,7 +193,7 @@ (or/c (cons/c symbol? (or/c symbol? #f)) free-id-info?)))))])) -(define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) +(define-form-struct (phase-shift wrap) ([amt (or/c exact-integer? #f)] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) (define-form-struct (wrap-mark wrap) ([val exact-integer?])) (define-form-struct (prune wrap) ([sym any/c])) From 95e04516563b649113e6c7cff6ad7da17ae074ed Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 May 2012 06:54:17 -0600 Subject: [PATCH 261/466] zo-parse update for phase-shift syntax object marshaling original commit: 92db2b4fb33e5a79ade49271e88fee22cc7b81e4 --- collects/compiler/zo-parse.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 4ddf836aab..84e5082332 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -686,7 +686,7 @@ [(box? a) (match (unbox a) [(list (? symbol?) ...) (make-prune (unbox a))] - [`#(,amt ,src ,dest #f #f) + [`#(,amt ,src ,dest #f #f ,cancel-id) (make-phase-shift amt (parse-module-path-index cp src) (parse-module-path-index cp dest))] From c9f62c0bc573caaef55181929ecbc5eacbbd3f41 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 May 2012 08:59:36 -0600 Subject: [PATCH 262/466] fix `compiler/zo-parse', etc. for phase-shift addition original commit: d93f4214a4c60a24ce142cdcb38f21a1befb9c81 --- collects/compiler/decompile.rkt | 4 ++-- collects/compiler/zo-marshal.rkt | 4 ++-- collects/compiler/zo-parse.rkt | 3 ++- collects/compiler/zo-structs.rkt | 5 ++++- 4 files changed, 10 insertions(+), 6 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index ac8808a940..ff3d99c342 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -144,8 +144,8 @@ ignored alist) `(,(if has-free-id-renames? 'lexical/free-id=? 'lexical) . ,alist)] - [(phase-shift amt src dest) - `(phase-shift ,amt ,src ,dest)] + [(phase-shift amt src dest cancel-id) + `(phase-shift ,amt ,src ,dest, cancel-id)] [(wrap-mark val) val] [(prune sym) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index a05194725d..a9a1179f88 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -416,8 +416,8 @@ (define (encode-wraps wraps) (for/list ([wrap (in-list wraps)]) (match wrap - [(struct phase-shift (amt src dest)) - (box (vector amt src dest #f #f))] + [(struct phase-shift (amt src dest cancel-id)) + (box (vector amt src dest #f #f cancel-id))] [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) (define encoded-kind (eq? kind 'marked)) (define encoded-unmarshals (map encode-all-from-module unmarshals)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 84e5082332..ca9776446d 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -689,7 +689,8 @@ [`#(,amt ,src ,dest #f #f ,cancel-id) (make-phase-shift amt (parse-module-path-index cp src) - (parse-module-path-index cp dest))] + (parse-module-path-index cp dest) + cancel-id)] [else (error 'parse "bad phase shift: ~e" a)])] [else (error 'decode-wraps "bad wrap element: ~e" a)]))) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 03b53d31dc..39da7d1fb2 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -193,7 +193,10 @@ (or/c (cons/c symbol? (or/c symbol? #f)) free-id-info?)))))])) -(define-form-struct (phase-shift wrap) ([amt (or/c exact-integer? #f)] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) +(define-form-struct (phase-shift wrap) ([amt (or/c exact-integer? #f)] + [src (or/c module-path-index? #f)] + [dest (or/c module-path-index? #f)] + [cancel-id (or/c exact-integer? #f)])) (define-form-struct (wrap-mark wrap) ([val exact-integer?])) (define-form-struct (prune wrap) ([sym any/c])) From 767cae7e20f4d9287ed80514fa39d693f33d4263 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 16 May 2012 06:37:03 -0600 Subject: [PATCH 263/466] raco decompile: show `require's original commit: 68029b4adec9f7f8596d9056574ded551265a8f6 --- collects/compiler/decompile.rkt | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index ff3d99c342..9341f939c1 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -4,7 +4,8 @@ racket/port racket/match racket/list - racket/set) + racket/set + racket/path) (provide decompile) @@ -162,7 +163,10 @@ (cond [(symbol? modidx) modidx] [else - (collapse-module-path-index modidx (current-directory))])) + (collapse-module-path-index modidx (build-path + (or (current-load-relative-directory) + (current-directory)) + "here.rkt"))])) (define (decompile-module mod-form orig-stack stx-ht mod-name) (match mod-form @@ -172,6 +176,28 @@ [(stack) (append '(#%modvars) orig-stack)] [(closed) (make-hasheq)]) `(,mod-name ,(if (symbol? name) name (last name)) .... + ,@(let ([l (apply + append + (for/list ([req (in-list requires)] + #:when (pair? (cdr req))) + (define l (for/list ([mpi (in-list (cdr req))]) + (define p (mpi->string mpi)) + (if (path? p) + (let ([d (current-load-relative-directory)]) + (path->string (if d + (find-relative-path d p #:more-than-root? #t) + p))) + p))) + (if (eq? 0 (car req)) + l + `((,@(case (car req) + [(#f) `(for-label)] + [(1) `(for-syntax)] + [else `(for-meta ,(car req))]) + ,@l)))))]) + (if (null? l) + null + `((require ,@l)))) ,@defns ,@(for/list ([submod (in-list pre-submodules)]) (decompile-module submod orig-stack stx-ht 'module)) From fd364dc2dee5fe677e28888c3f297cdd648d5503 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 28 May 2012 20:30:58 -0600 Subject: [PATCH 264/466] raco exe: checks on source and destination paths Disallow creating a launcher whose source is the launcher itself, for example. original commit: 2fcb635790c653bf0b0213acd8de8127fb1930de --- collects/compiler/commands/exe.rkt | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index b18f17dabc..79254aa879 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/cmdline +#lang racket/base +(require racket/cmdline raco/command-name compiler/private/embed launcher/launcher @@ -73,6 +73,23 @@ (extract-base-filename/ss source-file (string->symbol (short-program+command-name)))) (gui))]) + (unless (file-exists? source-file) + (raise-user-error (string->symbol (short-program+command-name)) + "source file does not exist\n path: ~a" source-file)) + (with-handlers ([exn:fail:filesystem? (lambda (exn) (void))]) + (call-with-input-file* dest + (lambda (dest-in) + (call-with-input-file* source-file + (lambda (source-in) + (when (equal? (port-file-identity dest-in) + (port-file-identity source-in)) + (raise-user-error (string->symbol (short-program+command-name)) + (string-append + "source file is the same as the destination file" + "\n source path: ~a" + "\n destination path: ~a") + source-file + dest))))))) (cond [(launcher) (parameterize ([current-launcher-variant (if (3m) '3m 'cgc)]) From 359eb87abbd56fd634de90a35fae31be1be914e9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 23 Jun 2012 05:21:08 -0700 Subject: [PATCH 265/466] fix zo-parse, zo-struct, etc. for context in whole-module import original commit: 6173b7eb058a99384567a20ab6778c1d6f350e6e --- collects/compiler/zo-marshal.rkt | 8 +++++--- collects/compiler/zo-parse.rkt | 18 ++++++++++++------ collects/compiler/zo-structs.rkt | 8 +++++--- 3 files changed, 22 insertions(+), 12 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index a9a1179f88..dc52cfd82e 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -406,11 +406,13 @@ (define (encode-all-from-module afm) (match afm - [(struct all-from-module (path phase src-phase #f #f)) + [(struct all-from-module (path phase src-phase null #f null)) (list* path phase src-phase)] - [(struct all-from-module (path phase src-phase exns #f)) + [(struct all-from-module (path phase src-phase null #f context)) + (list* path phase context src-phase)] + [(struct all-from-module (path phase src-phase exns #f null)) (list* path phase exns src-phase)] - [(struct all-from-module (path phase src-phase exns (vector prefix))) + [(struct all-from-module (path phase src-phase exns prefix null)) (list* path phase src-phase exns prefix)])) (define (encode-wraps wraps) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index ca9776446d..4e2484cc7b 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -694,25 +694,31 @@ [else (error 'parse "bad phase shift: ~e" a)])] [else (error 'decode-wraps "bad wrap element: ~e" a)]))) +(define (afm-context? v) + (or (and (list? v) (andmap exact-integer? v)) + (and (vector? v) + (= 2 (vector-length v)) + (list? (vector-ref v 0)) + (andmap exact-integer? (vector-ref v 0))))) + (define all-from-module-memo (make-memo)) (define (decode-all-from-module cp afm) (define (phase? v) (or (number? v) (not v))) (with-memo all-from-module-memo afm (match afm - [(list* path (? phase? phase) (? phase? src-phase) - (list exn ...) prefix) + [(list* path (? phase? phase) (? phase? src-phase) (list exn ...) prefix) (make-all-from-module (parse-module-path-index cp path) - phase src-phase exn (vector prefix))] - [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) + phase src-phase exn prefix null)] + [(list* path (? phase? phase) (? afm-context? context) (? phase? src-phase)) (make-all-from-module (parse-module-path-index cp path) - phase src-phase exn #f)] + phase src-phase null #f context)] [(list* path (? phase? phase) (? phase? src-phase)) (make-all-from-module (parse-module-path-index cp path) - phase src-phase #f #f)]))) + phase src-phase null #f null)]))) (define wraps-memo (make-memo)) (define (decode-wraps cp w) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 39da7d1fb2..b770a6a66d 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -202,9 +202,11 @@ (define-form-struct all-from-module ([path module-path-index?] [phase (or/c exact-integer? #f)] - [src-phase any/c] ; should be (or/c exact-integer? #f) - [exceptions (or/c (listof (or/c symbol? number?)) #f)] ; should be (listof symbol?) - [prefix (or/c (vector/c (or/c symbol? #f)) #f)])) ; should be (or/c symbol? #f) + [src-phase (or/c exact-integer? #f)] + [exceptions (listof symbol?)] + [prefix (or/c symbol? #f)] + [context (or/c (listof exact-integer?) + (vector/c (listof exact-integer?) any/c))])) (define-form-struct nominal-path ()) (define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?])) From 4be962e7200a932900c9f615d1c0b5c6743dfe5d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Jun 2012 23:26:07 -0600 Subject: [PATCH 266/466] fix problems with references to bindings at higher phases original commit: 577cf4592e1ad079524af05be4abbf05a60751f1 --- collects/compiler/zo-marshal.rkt | 3 ++- collects/compiler/zo-parse.rkt | 2 +- collects/compiler/zo-structs.rkt | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index dc52cfd82e..255b327f4c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -610,7 +610,8 @@ (out-anything modidx out) (out-anything sym out) (unless (zero? phase) - (out-number -2 out)) + (out-number -2 out) + (out-number phase out)) (out-number pos out)] [(struct closure (lam gen-id)) (out-byte CPT_CLOSURE out) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 4e2484cc7b..229ecc9544 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -859,7 +859,7 @@ [pos (read-compact-number cp)]) (let-values ([(mod-phase pos) (if (= pos -2) - (values 1 (read-compact-number cp)) + (values (read-compact-number cp) (read-compact-number cp)) (values 0 pos))]) (make-module-variable mod var pos mod-phase)))] [(local-unbox) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index b770a6a66d..a6c9749db9 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -43,7 +43,7 @@ (define-form-struct module-variable ([modidx module-path-index?] [sym symbol?] [pos exact-integer?] - [phase (or/c 0 1)])) ; direct access to exported id + [phase exact-nonnegative-integer?])) ;; Syntax object (define ((alist/c k? v?) l) From a8aec864b9e32d9bbc5756490e006e105f269e9c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 29 Jun 2012 10:49:51 -0600 Subject: [PATCH 267/466] `raco decompile' fix original commit: c69ea5569f38e5ac15113369cf42fd197114a1f3 --- collects/compiler/decompile.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 9341f939c1..645d294e68 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -185,7 +185,9 @@ (if (path? p) (let ([d (current-load-relative-directory)]) (path->string (if d - (find-relative-path d p #:more-than-root? #t) + (find-relative-path (simplify-path d #t) + (simplify-path p #f) + #:more-than-root? #t) p))) p))) (if (eq? 0 (car req)) From 3fcc8dc945a78f30bf2f38c52ec3282de3795c44 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Jul 2012 09:49:39 -0600 Subject: [PATCH 268/466] more submodule repairs for `raco exe' original commit: a605183a0aae9f07141e204ca40100b3035add8d --- collects/tests/racket/embed-me17.rkt | 2 ++ collects/tests/racket/embed-me17a.rkt | 9 +++++++++ collects/tests/racket/embed-me18a.rkt | 9 +++++++++ collects/tests/racket/embed-planet-1/dyn-sub.rkt | 8 ++++++++ collects/tests/racket/embed-planet-1/has-sub.rkt | 5 ++++- collects/tests/racket/embed.rktl | 4 ++++ 6 files changed, 36 insertions(+), 1 deletion(-) create mode 100644 collects/tests/racket/embed-me17.rkt create mode 100644 collects/tests/racket/embed-me17a.rkt create mode 100644 collects/tests/racket/embed-me18a.rkt create mode 100644 collects/tests/racket/embed-planet-1/dyn-sub.rkt diff --git a/collects/tests/racket/embed-me17.rkt b/collects/tests/racket/embed-me17.rkt new file mode 100644 index 0000000000..ecac985e4a --- /dev/null +++ b/collects/tests/racket/embed-me17.rkt @@ -0,0 +1,2 @@ +#lang racket/base +(require (submod "embed-me17a.rkt" sub)) diff --git a/collects/tests/racket/embed-me17a.rkt b/collects/tests/racket/embed-me17a.rkt new file mode 100644 index 0000000000..a6826d7597 --- /dev/null +++ b/collects/tests/racket/embed-me17a.rkt @@ -0,0 +1,9 @@ +#lang racket + +(define print-17 + (lambda () (printf "This is 17.\n"))) + +(module+ sub + (with-output-to-file "stdout" + print-17 + #:exists 'append)) diff --git a/collects/tests/racket/embed-me18a.rkt b/collects/tests/racket/embed-me18a.rkt new file mode 100644 index 0000000000..107e3fedd2 --- /dev/null +++ b/collects/tests/racket/embed-me18a.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(module sub racket/base + (provide print-18) + (define (print-18) + (printf "This is 18.\n"))) + + + + \ No newline at end of file diff --git a/collects/tests/racket/embed-planet-1/dyn-sub.rkt b/collects/tests/racket/embed-planet-1/dyn-sub.rkt new file mode 100644 index 0000000000..081b7ffd4e --- /dev/null +++ b/collects/tests/racket/embed-planet-1/dyn-sub.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require (submod (planet racket-tester/p1/has-sub) the-sub)) + +(with-output-to-file "stdout" + #:exists 'append + (lambda () (displayln (dynamic-require + '(submod (planet racket-tester/p1/has-sub) the-sub) + 'out)))) diff --git a/collects/tests/racket/embed-planet-1/has-sub.rkt b/collects/tests/racket/embed-planet-1/has-sub.rkt index e9a5a07112..e2f1bb7de1 100644 --- a/collects/tests/racket/embed-planet-1/has-sub.rkt +++ b/collects/tests/racket/embed-planet-1/has-sub.rkt @@ -1,3 +1,6 @@ #lang racket/base -(module+ the-sub) +(module+ the-sub + (provide out) + (define out 'out)) + diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 1ccbc1bafd..9f95f62cf1 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -224,6 +224,8 @@ (one-mz-test "embed-me13.rkt" "This is 14\n" #f) (one-mz-test "embed-me14.rkt" "This is 14\n" #f) (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) + (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) + (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -501,6 +503,8 @@ (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") + (go '(planet racket-tester/p1/dyn-sub) "out\n") + (void)) (system* planet "unlink" "racket-tester" "p1.plt" "1" "0") From 3c46e5fdc60481bcfc8edea92f55c8456191ca29 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Jul 2012 11:32:21 -0500 Subject: [PATCH 269/466] fixes for submodules and `variable-reference->namespace' Closes PR 12925 Merge to 5.3 original commit: d95ec4d454efc8a98bfbe2ad055c020ee7af880e --- collects/compiler/zo-structs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index a6c9749db9..d16b9fbd66 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -124,7 +124,7 @@ [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx?)] + [internal-context (or/c #f #t stx? (listof stx?))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) From 462f389bb224e0688d80b34e733f0010aaa3d7b7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Jul 2012 07:07:38 -0500 Subject: [PATCH 270/466] normalize module rename info to vector in ".zo" format This is related to the receent repairs for submodules and `variable-reference->namespace'. Merge to v5.3 original commit: 5a1bc5ad4001b1ac0203aee3852d8a5694b818d1 --- collects/compiler/zo-structs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index d16b9fbd66..1065cf265c 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -124,7 +124,7 @@ [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx? (listof stx?))] + [internal-context (or/c #f #t stx? (vectorof stx?))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) From 841bbb465d823f0381276d64ef7fc78ae976dd88 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Aug 2012 15:31:34 -0600 Subject: [PATCH 271/466] compiler/zo-marshal: repair mashaling of import info in syntax original commit: 0bd53a35492f3c64fa207b5633248d48a8304b6b --- collects/compiler/zo-marshal.rkt | 8 +++----- collects/tests/compiler/zo-test.rkt | 7 ++++++- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 255b327f4c..e0a96c0feb 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -406,13 +406,11 @@ (define (encode-all-from-module afm) (match afm - [(struct all-from-module (path phase src-phase null #f null)) + [(struct all-from-module (path phase src-phase '() #f '())) (list* path phase src-phase)] - [(struct all-from-module (path phase src-phase null #f context)) + [(struct all-from-module (path phase src-phase '() #f context)) (list* path phase context src-phase)] - [(struct all-from-module (path phase src-phase exns #f null)) - (list* path phase exns src-phase)] - [(struct all-from-module (path phase src-phase exns prefix null)) + [(struct all-from-module (path phase src-phase exns prefix '())) (list* path phase src-phase exns prefix)])) (define (encode-wraps wraps) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index 672b8677c8..5c7694085f 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -18,6 +18,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (define invariant-output (make-parameter #f)) (define time-limit (make-parameter +inf.0)) (define randomize (make-parameter #f)) +(define num-processes (make-parameter (processor-count))) (define errors (make-hash)) (define (record-common-error! exn-msg) @@ -89,6 +90,10 @@ exec racket -t "$0" -- -s -t 60 -v -R $* number "Limit the run to a given amount of time" (time-limit (string->number number))] + [("-j") + n + "Run in parallel" + (num-processes (string->number n))] #:args p (if (empty? p) (list (find-collects-dir)) @@ -99,7 +104,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (define from-worker-ch (make-channel)) (define worker-threads - (for/list ([i (in-range (processor-count))]) + (for/list ([i (in-range (num-processes))]) (thread (λ () (let loop () From f6441369d96142edd49351956ea2a761593cdaad Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 23 Sep 2012 10:47:24 -0500 Subject: [PATCH 272/466] raco exe: handle failing submodule search correctly An attempt to detect a submodule could trigger the original module name resolver when the would-be enclosing module would be handled by the embedding-specific resolver. When a submodule is not found but its would-be enclosing module is embedded, then assume that the default resolver wouldn't find the submodule, eithe --- and therefore avoid a potential "collection not found" error. original commit: 3fb12b4ff48276a744d80a8d4bb1fc1655c6cabd --- collects/tests/racket/embed-me19.rkt | 13 +++++++++++++ collects/tests/racket/embed.rktl | 1 + 2 files changed, 14 insertions(+) create mode 100644 collects/tests/racket/embed-me19.rkt diff --git a/collects/tests/racket/embed-me19.rkt b/collects/tests/racket/embed-me19.rkt new file mode 100644 index 0000000000..158643bc6c --- /dev/null +++ b/collects/tests/racket/embed-me19.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require racket/runtime-path) + +(define-runtime-module-path plai plai) +(define-runtime-module-path plai-reader plai/lang/reader) + +(parameterize ([read-accept-reader #t]) + (namespace-require 'racket/base) + (eval (read (open-input-string "#lang plai 10")))) + +(with-output-to-file "stdout" + (lambda () (printf "This is 19.\n")) + #:exists 'append) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 9f95f62cf1..5c7b6ba662 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -226,6 +226,7 @@ (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) + (one-mz-test "embed-me19.rkt" "This is 19.\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode") From 639af63b3f75f464fb25604c492087e9c47ee585 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Oct 2012 15:36:23 -0600 Subject: [PATCH 273/466] fix planet `raco exe' tests Merge ot v5.3.1 original commit: bd146e2d8d2f9f8fdbe071c1943a665d3b17bfbe --- collects/tests/racket/embed.rktl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 5c7b6ba662..47c5183ea7 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -473,9 +473,9 @@ "planet"))) (define (try-planet) - (system* planet "link" "racket-tester" "p1.plt" "1" "0" + (system* raco "planet" "link" "racket-tester" "p1.plt" "1" "0" (path->string (collection-path "tests" "racket" "embed-planet-1"))) - (system* planet "link" "racket-tester" "p2.plt" "2" "2" + (system* raco "planet" "link" "racket-tester" "p2.plt" "2" "2" (path->string (collection-path "tests" "racket" "embed-planet-2"))) (let ([go (lambda (path expected) @@ -508,8 +508,8 @@ (void)) - (system* planet "unlink" "racket-tester" "p1.plt" "1" "0") - (system* planet "unlink" "racket-tester" "p2.plt" "2" "2")) + (system* raco "planet" "unlink" "racket-tester" "p1.plt" "1" "0") + (system* raco "planet" "unlink" "racket-tester" "p2.plt" "2" "2")) ;; ---------------------------------------- From 5eaf286081f253b498f72082e19dbc15e55e4204 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Oct 2012 16:14:29 -0600 Subject: [PATCH 274/466] fix `raco exe' for `module+' submodules Closes PR 13116 Merge to v5.3.1 original commit: e1a6d2b07d263ababc89642ab78f6e17fce19be4 --- collects/tests/racket/embed-me20.rkt | 7 +++++++ collects/tests/racket/embed.rktl | 8 ++++++++ 2 files changed, 15 insertions(+) create mode 100644 collects/tests/racket/embed-me20.rkt diff --git a/collects/tests/racket/embed-me20.rkt b/collects/tests/racket/embed-me20.rkt new file mode 100644 index 0000000000..d4b8fe1586 --- /dev/null +++ b/collects/tests/racket/embed-me20.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +;; like "embed-me16.rkt" using `module+' +(module+ main + (with-output-to-file "stdout" + (lambda () (printf "This is 20.\n")) + #:exists 'append)) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 47c5183ea7..39da0cdd83 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -288,6 +288,14 @@ (path->string (build-path (collection-path "tests" "racket") "embed-me16.rkt"))) (try-exe (mk-dest mred?) "This is 16.\n" mred?) + ;; raco exe on a module with a `main' submodule+ + (system* raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "racket") "embed-me20.rkt"))) + (try-exe (mk-dest mred?) "This is 20.\n" mred?) + ;;raco exe --launcher (system* raco "exe" From 4807353e8d7c2e90e17a0eac09b12fd12607cd0f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Oct 2012 07:09:56 -0600 Subject: [PATCH 275/466] bytecode validator: check "constant" annotations on variable references Bytecode changes in two small ways to help the validator: * a cross-module variable reference preserves the compiler's annotation on whether the reference is constant, fixed, or other * lifted procedures now appear in the module body just before the definitions that use them, instead of at the beginning of the module body original commit: e59066debe046e808263e26387e94d6fcdb79f2a --- collects/compiler/decompile.rkt | 2 +- collects/compiler/demodularizer/merge.rkt | 4 ++-- collects/compiler/demodularizer/nodep.rkt | 2 +- collects/compiler/zo-marshal.rkt | 6 +++++- collects/compiler/zo-parse.rkt | 20 +++++++++++++++----- collects/compiler/zo-structs.rkt | 3 ++- 6 files changed, 26 insertions(+), 11 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 645d294e68..1411e6d50f 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -73,7 +73,7 @@ [(? symbol?) (string->symbol (format "_~a" tl))] [(struct global-bucket (name)) (string->symbol (format "_~a" name))] - [(struct module-variable (modidx sym pos phase)) + [(struct module-variable (modidx sym pos phase constantness)) (if (and (module-path-index? modidx) (let-values ([(n b) (module-path-index-split modidx)]) (and (not n) (not b)))) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index aff21cee1b..5b087e257f 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -59,7 +59,7 @@ (define (compute-new-modvar mv rw) (match mv - [(struct module-variable (modidx sym pos phase)) + [(struct module-variable (modidx sym pos phase constantness)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) (log-debug (format "Rewriting ~a of ~S" pos (mpi->path* modidx))) @@ -76,7 +76,7 @@ [remap empty]) ([tl (in-list mod-toplevels)]) (match tl - [(and mv (struct module-variable (modidx sym pos phase))) + [(and mv (struct module-variable (modidx sym pos phase constantness))) (define rw ((current-get-modvar-rewrite) modidx)) ; XXX We probably don't need to deal with #f phase (unless (or (not phase) (zero? phase)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index cb717a1a2c..60afbaf7ec 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -118,7 +118,7 @@ (define new-prefix prefix) ; Cache all the mpi paths (for-each (match-lambda - [(and mv (struct module-variable (modidx sym pos phase))) + [(and mv (struct module-variable (modidx sym pos phase constantness))) (mpi->path! modidx)] [tl (void)]) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e0a96c0feb..9f39c208ad 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -603,10 +603,14 @@ (out-byte CPT_FALSE out)] [(? void?) (out-byte CPT_VOID out)] - [(struct module-variable (modidx sym pos phase)) + [(struct module-variable (modidx sym pos phase constantness)) (out-byte CPT_MODULE_VAR out) (out-anything modidx out) (out-anything sym out) + (case constantness + [(constant) (out-number -4 out)] + [(fixed) (out-number -5 out)] + [else (void)]) (unless (zero? phase) (out-number -2 out) (out-number phase out)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 229ecc9544..13856e48e0 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -857,11 +857,21 @@ (let ([mod (read-compact cp)] [var (read-compact cp)] [pos (read-compact-number cp)]) - (let-values ([(mod-phase pos) - (if (= pos -2) - (values (read-compact-number cp) (read-compact-number cp)) - (values 0 pos))]) - (make-module-variable mod var pos mod-phase)))] + (let-values ([(flags mod-phase pos) + (let loop ([pos pos]) + (cond + [(pos . < . -3) + (let ([real-pos (read-compact-number cp)]) + (define-values (_ m p) (loop real-pos)) + (values (- (+ pos 3)) m p))] + [(= pos -2) + (values 0 (read-compact-number cp) (read-compact-number cp))] + [else (values 0 0 pos)]))]) + (make-module-variable mod var pos mod-phase + (cond + [(not (zero? (bitwise-and #x1 flags))) 'constant] + [(not (zero? (bitwise-and #x2 flags))) 'fixed] + [else #f]))))] [(local-unbox) (let* ([p* (read-compact-number cp)] [p (if (< p* 0) (- (add1 p*)) p*)] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 1065cf265c..3fc6b2c11d 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -43,7 +43,8 @@ (define-form-struct module-variable ([modidx module-path-index?] [sym symbol?] [pos exact-integer?] - [phase exact-nonnegative-integer?])) + [phase exact-nonnegative-integer?] + [constantness (or/c #f 'constant 'fixed)])) ;; Syntax object (define ((alist/c k? v?) l) From ad98dc0ddf06f4097fffc06583f069c7fccee825 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Oct 2012 09:28:15 -0600 Subject: [PATCH 276/466] track import "shapes" as procedure or structure type Shape information allows the linker to check the importing module's compile-time expectation against the run-time value of its imports. The JIT, in turn, can rely on that checking to better inline structure-type predicates, etc., and to more directy call JIT-generated code across module boundaries. In addition to checking the "shape" of an import, the import's JITted vs. non-JITted state must be consistent. To prevent shifts in JIT state, the `eval-jit-enabled' parameter is now restricted in its effect to top-level bindings. original commit: d7bf6776450abf0524975a2b09e8568760621e77 --- collects/compiler/decompile.rkt | 15 +++++++++++- collects/compiler/zo-marshal.rkt | 42 ++++++++++++++++++++++++++++++-- collects/compiler/zo-parse.rkt | 28 +++++++++++++++++++++ collects/compiler/zo-structs.rkt | 15 +++++++++++- 4 files changed, 96 insertions(+), 4 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 1411e6d50f..2217060f65 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -78,7 +78,20 @@ (let-values ([(n b) (module-path-index-split modidx)]) (and (not n) (not b)))) (string->symbol (format "_~a" sym)) - (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) + (string->symbol (format "_~s~a@~s~a" + sym + (match constantness + ['constant ":c"] + ['fixed ":f"] + [(function-shape a pm?) + (if pm? ":P" ":p")] + [(struct-type-shape c) ":t"] + [(constructor-shape a) ":mk"] + [(predicate-shape) ":?"] + [(accessor-shape c) ":ref"] + [(mutator-shape c) ":set!"] + [else ""]) + (mpi->string modidx) (if (zero? phase) "" (format "/~a" phase)))))] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 9f39c208ad..b9e1333a99 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -604,13 +604,51 @@ [(? void?) (out-byte CPT_VOID out)] [(struct module-variable (modidx sym pos phase constantness)) + (define (to-sym n) (string->symbol (format "struct~a" n))) (out-byte CPT_MODULE_VAR out) (out-anything modidx out) (out-anything sym out) + (out-anything (cond + [(function-shape? constantness) + (let ([a (function-shape-arity constantness)]) + (cond + [(arity-at-least? a) + (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) + (if (function-shape-preserves-marks? constantness) 1 0))] + [(list? a) + (string->symbol (apply + string-append + (add-between + (for/list ([a (in-list a)]) + (define n (if (arity-at-least? a) + (- (add1 (arity-at-least-value a))) + a)) + (number->string n)) + ":")))] + [else + (bitwise-ior (arithmetic-shift a 1) + (if (function-shape-preserves-marks? constantness) 1 0))]))] + [(struct-type-shape? constantness) + (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) + 4))] + [(constructor-shape? constantness) + (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) + 4)))] + [(predicate-shape? constantness) (to-sym 2)] + [(accessor-shape? constantness) + (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) + 4)))] + [(mutator-shape? constantness) + (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) + 4)))] + [(struct-other-shape? constantness) + (to-sym 5)] + [else #f]) + out) (case constantness - [(constant) (out-number -4 out)] + [(#f) (void)] [(fixed) (out-number -5 out)] - [else (void)]) + [else (out-number -4 out)]) (unless (zero? phase) (out-number -2 out) (out-number phase out)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 13856e48e0..18e7426b01 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -856,6 +856,7 @@ [(module-var) (let ([mod (read-compact cp)] [var (read-compact cp)] + [shape (read-compact cp)] [pos (read-compact-number cp)]) (let-values ([(flags mod-phase pos) (let loop ([pos pos]) @@ -869,6 +870,33 @@ [else (values 0 0 pos)]))]) (make-module-variable mod var pos mod-phase (cond + [shape + (cond + [(number? shape) + (define n (arithmetic-shift shape -1)) + (make-function-shape (if (negative? n) + (make-arity-at-least (sub1 (- n))) + n) + (odd? shape))] + [(and (symbol? shape) + (regexp-match? #rx"^struct" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 6))) + (case (bitwise-and n #x7) + [(0) (make-struct-type-shape (arithmetic-shift n -3))] + [(1) (make-constructor-shape (arithmetic-shift n -3))] + [(2) (make-predicate-shape)] + [(3) (make-accessor-shape (arithmetic-shift n -3))] + [(4) (make-mutator-shape (arithmetic-shift n -3))] + [else (make-struct-other-shape)])] + [else + ;; parse symbol as ":"-separated sequence of arities + (make-function-shape + (for/list ([s (regexp-split #rx":" (symbol->string shape))]) + (define i (string->number s)) + (if (negative? i) + (make-arity-at-least (sub1 (- i))) + i)) + #f)])] [(not (zero? (bitwise-and #x1 flags))) 'constant] [(not (zero? (bitwise-and #x2 flags))) 'fixed] [else #f]))))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 3fc6b2c11d..a2aa9c284b 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -38,13 +38,26 @@ [(_ id . rest) (define-form-struct* id (id zo) . rest)])) +(define-form-struct function-shape ([arity procedure-arity?] + [preserves-marks? boolean?])) + +(define-form-struct struct-shape ()) +(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) +(define-form-struct (predicate-shape struct-shape) ()) +(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-other-shape struct-shape) ()) + ;; In toplevels of resove prefix: (define-form-struct global-bucket ([name symbol?])) ; top-level binding (define-form-struct module-variable ([modidx module-path-index?] [sym symbol?] [pos exact-integer?] [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed)])) + [constantness (or/c #f 'constant 'fixed + function-shape? + struct-shape?)])) ;; Syntax object (define ((alist/c k? v?) l) From 0dd947ab1589304879648a780799ebb347b484db Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:19:53 -0500 Subject: [PATCH 277/466] `#lang racket' -> `#lang racket/base' conversions in demodularizer. original commit: 4c8d1f67b253473fe3febe783cc2e637c66729de --- collects/compiler/demodularizer/alpha.rkt | 5 ++- collects/compiler/demodularizer/batch.rkt | 4 +- .../compiler/demodularizer/gc-toplevels.rkt | 38 ++++++++++--------- collects/compiler/demodularizer/merge.rkt | 20 ++++++---- collects/compiler/demodularizer/module.rkt | 8 +++- collects/compiler/demodularizer/mpi.rkt | 6 ++- collects/compiler/demodularizer/nodep.rkt | 11 ++++-- .../compiler/demodularizer/replace-modidx.rkt | 8 +++- .../demodularizer/update-toplevels.rkt | 7 +++- collects/compiler/demodularizer/util.rkt | 6 ++- 10 files changed, 72 insertions(+), 41 deletions(-) diff --git a/collects/compiler/demodularizer/alpha.rkt b/collects/compiler/demodularizer/alpha.rkt index 9b459b6ca3..2f3c71398d 100644 --- a/collects/compiler/demodularizer/alpha.rkt +++ b/collects/compiler/demodularizer/alpha.rkt @@ -1,5 +1,6 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/match racket/contract compiler/zo-parse) (define (alpha-vary-ctop top) (match top diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index afb495a473..bd98894ad3 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + #| Here's the idea: @@ -40,6 +41,7 @@ Here's the idea: (require racket/pretty racket/system + racket/cmdline "mpi.rkt" "util.rkt" "nodep.rkt" diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index aa6b780389..ad8c74faee 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -1,5 +1,10 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/match + racket/list + racket/dict + racket/contract + compiler/zo-parse "util.rkt") ; XXX Use efficient set structure @@ -150,21 +155,20 @@ (match (dict-ref g n) [(struct refs (n-tls n-stxs)) (hash-set! visited? n #t) - (local - [(define-values (new-tls1 new-stxs1) - (for/fold ([new-tls tls] - [new-stxs stxs]) - ([tl (in-list n-tls)]) - (visit-tl tl new-tls new-stxs))) - (define new-stxs2 - (for/fold ([new-stxs new-stxs1]) - ([stx (in-list n-stxs)]) - (define this-stx (visit-stx stx)) - (if this-stx - (list* this-stx new-stxs) - new-stxs)))] - (values (list* n new-tls1) - new-stxs2))]))) + (define-values (new-tls1 new-stxs1) + (for/fold ([new-tls tls] + [new-stxs stxs]) + ([tl (in-list n-tls)]) + (visit-tl tl new-tls new-stxs))) + (define new-stxs2 + (for/fold ([new-stxs new-stxs1]) + ([stx (in-list n-stxs)]) + (define this-stx (visit-stx stx)) + (if this-stx + (list* this-stx new-stxs) + new-stxs))) + (values (list* n new-tls1) + new-stxs2)]))) (define stx-visited? (make-hasheq)) (define (visit-stx n) (if (hash-has-key? stx-visited? n) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 5b087e257f..f118e6b9e4 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" "nodep.rkt" @@ -156,12 +160,12 @@ (cond [(mod-lift-start . <= . n) ; This is a lift - (local [(define which-lift (- n mod-lift-start)) - (define lift-tl (+ top-lift-start lift-offset which-lift))] - (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl)] + (define which-lift (- n mod-lift-start)) + (define lift-tl (+ top-lift-start lift-offset which-lift)) + (when (lift-tl . >= . max-toplevel) + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) + lift-tl] [else (list-ref toplevel-remap n)])) (lambda (n) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 9c907a5153..dca4498fec 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt") (define (->module-path-index s) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index 10f8cd23a5..bb430570dc 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -1,5 +1,7 @@ -#lang racket -(require syntax/modresolve) +#lang racket/base + +(require racket/contract + syntax/modresolve) (define current-module-path (make-parameter #f)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 60afbaf7ec..4e55b46545 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" racket/set) @@ -92,7 +96,8 @@ (define (nodep-form form phase) (if (mod? form) - (local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))] + (let-values ([(modvar-rewrite lang-info mods) + (nodep-module form phase)]) (values modvar-rewrite lang-info (make-splice mods))) (error 'nodep-form "Doesn't support non mod forms"))) diff --git a/collects/compiler/demodularizer/replace-modidx.rkt b/collects/compiler/demodularizer/replace-modidx.rkt index 7ad45cbc56..f470e2b8f1 100644 --- a/collects/compiler/demodularizer/replace-modidx.rkt +++ b/collects/compiler/demodularizer/replace-modidx.rkt @@ -1,6 +1,10 @@ -#lang racket -(require unstable/struct +#lang racket/base + +(require racket/match + racket/vector + unstable/struct "util.rkt") + (provide replace-modidx) (define (replace-modidx expr self-modidx) diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 3cc4ef9e14..6c1c83704e 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -1,5 +1,8 @@ -#lang racket -(require compiler/zo-structs +#lang racket/base + +(require racket/match + racket/contract + compiler/zo-structs "util.rkt") (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 1865bc133f..e18966798e 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -1,5 +1,7 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/contract + compiler/zo-parse) (define (prefix-syntax-start pre) (length (prefix-toplevels pre))) From 85715ca473a8245196cb501465bc27a57ec5bff5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Nov 2012 07:47:30 -0700 Subject: [PATCH 278/466] fix demod for submodules original commit: 623265d1e8c798ac5c6f5b7e75d858fd5c9d4e75 --- collects/compiler/demodularizer/mpi.rkt | 20 +++++++++----- collects/compiler/demodularizer/nodep.rkt | 32 ++++++++++++++++++----- 2 files changed, 39 insertions(+), 13 deletions(-) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index bb430570dc..65c0b76ad7 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -18,16 +18,24 @@ (lambda () (define _pth (resolve-module-path-index mpi (current-module-path))) - (if (path? _pth) - (simplify-path _pth #t) - _pth)))) + (cond + [(path? _pth) (simplify-path _pth #t)] + [(and (pair? _pth) + (path? (cadr _pth))) + (list* 'submod (simplify-path (cadr _pth) #t) (cddr _pth))] + [else _pth])))) (define (mpi->path* mpi) (hash-ref (MODULE-PATHS) mpi (lambda () (error 'mpi->path* "Cannot locate cache of path for ~S" mpi)))) +(define submod-path/c + (cons/c 'submod + (cons/c (or/c symbol? path?) + (listof symbol?)))) + (provide/contract [MODULE-PATHS (parameter/c (or/c false/c hash?))] - [current-module-path (parameter/c path-string?)] - [mpi->path! (module-path-index? . -> . (or/c symbol? path?))] - [mpi->path* (module-path-index? . -> . (or/c symbol? path?))]) + [current-module-path (parameter/c (or/c path-string? submod-path/c))] + [mpi->path! (module-path-index? . -> . (or/c symbol? path? submod-path/c))] + [mpi->path* (module-path-index? . -> . (or/c symbol? path? pair? submod-path/c))]) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 4e55b46545..f6c70e2bb1 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -28,13 +28,28 @@ [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)]))) -(define (path->comp-top pth) - (hash-ref! (ZOS) pth +(define (path->comp-top pth submod) + (hash-ref! (ZOS) (cons pth submod) (λ () - (call-with-input-file pth zo-parse)))) + (define zo (call-with-input-file pth zo-parse)) + (if submod + (extract-submod zo submod) + zo)))) + +(define (extract-submod zo submod) + (define m (compilation-top-code zo)) + (struct-copy compilation-top + zo + [code (let loop ([m m]) + (if (and (pair? (mod-name m)) + (equal? submod (cdr (mod-name m)))) + m + (or (ormap loop (mod-pre-submodules m)) + (ormap loop (mod-post-submodules m)))))])) (define (excluded? pth) - (set-member? (current-excluded-modules) (path->string pth))) + (and (path? pth) + (set-member? (current-excluded-modules) (path->string pth)))) (define (get-nodep-module-code/index mpi phase) (define pth (mpi->path! mpi)) @@ -61,7 +76,9 @@ (hash-ref! MODULE-CACHE pth (lambda () - (define-values (base file dir?) (split-path pth)) + (define-values (base file dir?) (split-path (if (path-string? pth) + pth + (cadr pth)))) (define base-directory (if (path? base) (path->complete-path base (current-directory)) @@ -73,8 +90,9 @@ (parameterize ([current-load-relative-directory base-directory]) (path->comp-top (build-compiled-path - base - (path-add-suffix file #".zo")))) + base + (path-add-suffix file #".zo")) + (and (pair? pth) (cddr pth)))) pth phase))) (when (and phase (zero? phase)) From d003549257e7032de552d88741f4c04c549bf9a4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Nov 2012 10:03:07 -0700 Subject: [PATCH 279/466] bytecode compiler: generalize local-type tracking for unboxing Track fixnum results in the same way as flonum results to enable unboxing, if that turns out to be useful. The intent of the change, though, is to support other types in the future, such as "extnums". The output `raco decompile' no longer includes `#%in', `#%flonum', etc., annotations, which are mostly obvious and difficult to keep in sync with the implementation. A local-binding name now reflects a known type, however. The change includes a bug repair for he bytecode compiler that is independent of the generalization (i.e., the new test case triggered the old problem using flonums). original commit: bdf1c3e16548fa4c5b1b5cff37973477df271994 --- collects/compiler/decompile.rkt | 88 +++++--------------------------- collects/compiler/zo-marshal.rkt | 17 +++--- collects/compiler/zo-parse.rkt | 55 ++++++++++++-------- collects/compiler/zo-structs.rkt | 15 ++++-- 4 files changed, 66 insertions(+), 109 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 2217060f65..5ba6948567 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -330,16 +330,14 @@ [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack closed) ,(decompile-expr rhs globs stack closed))] - [(struct localref (unbox? offset clear? other-clears? flonum?)) + [(struct localref (unbox? offset clear? other-clears? type)) (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) id)]) (if clear? `(#%sfs-clear ,e) - (if flonum? - `(#%from-flonum ,e) - e))))] + e)))] [(? lam?) `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) @@ -347,13 +345,10 @@ ,@(map (lambda (lam) (decompile-lam lam globs stack closed)) lams))] - [(struct let-one (rhs body flonum? unused?)) + [(struct let-one (rhs body type unused?)) (let ([id (or (extract-id rhs) - (gensym (if unused? 'unused 'local)))]) - `(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)]) - (if flonum? - (list '#%as-flonum v) - v))]) + (gensym (or type (if unused? 'unused 'local))))]) + `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) ,(decompile-expr body globs (cons id stack) closed)))] [(struct let-void (count boxes? body)) (let ([ids (make-vector count #f)]) @@ -428,7 +423,10 @@ (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" - (case type [(ref) "argbox"] [(flonum) "argfl"] [else "arg"]) + (case type + [(ref) "argbox"] + [(val) "arg"] + [else (format "arg~a" type)]) i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) @@ -444,8 +442,8 @@ ,@(if (null? captures) null `('(captures: ,@(map (lambda (c t) - (if (eq? t 'flonum) - `(flonum ,c) + (if t + `(,t ,c) c)) captures closure-types) @@ -465,70 +463,10 @@ closed)))])) (define (annotate-inline a) - (if (and (symbol? (car a)) - (case (length a) - [(2) (memq (car a) '(not null? pair? mpair? symbol? - syntax? char? boolean? - number? real? exact-integer? - fixnum? inexact-real? - procedure? vector? box? string? bytes? eof-object? - zero? negative? exact-nonnegative-integer? - exact-positive-integer? - car cdr caar cadr cdar cddr - mcar mcdr unbox vector-length syntax-e - add1 sub1 - abs bitwise-not - list list* vector vector-immutable box))] - [(3) (memq (car a) '(eq? = <= < >= > - bitwise-bit-set? char=? - + - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor - arithmetic-shift vector-ref string-ref bytes-ref - set-mcar! set-mcdr! cons mcons set-box! - list list* vector vector-immutable))] - [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list list* vector vector-immutable - + - * / min max bitwise-and bitwise-ior bitwise-xor))] - [else (memq (car a) '(list list* vector vector-immutable - + - * / min max bitwise-and bitwise-ior bitwise-xor))])) - (cons '#%in a) - a)) + a) (define (annotate-unboxed args a) - (define (unboxable? e s) - (cond - [(localref? e) #t] - [(toplevel? e) #t] - [(eq? '#%flonum (car s)) #t] - [(not (expr? e)) #t] - [else #f])) - (if (and (symbol? (car a)) - (case (length a) - [(2) (memq (car a) '(flabs flsqrt ->fl - unsafe-flabs - unsafe-flsqrt - unsafe-fx->fl - flsin flcos fltan - flasin flacos flatan - flexp fllog - flfloor flceiling flround fltruncate - flmin flmax - unsafe-flmin unsafe-flmax))] - [(3) (memq (car a) '(fl+ fl- fl* fl/ - fl< fl> fl<= fl>= fl= - flvector-ref - unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ - unsafe-fl< unsafe-fl> - unsafe-fl= - unsafe-fl<= unsafe-fl>= - unsafe-flvector-ref - unsafe-f64vector-ref))] - - [(4) (memq (car a) '(flvector-set! - unsafe-flvector-set! - unsafe-f64vector-set!))] - [else #f]) - (andmap unboxable? args (cdr a))) - (cons '#%flonum a) - a)) + a) ;; ---------------------------------------- diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index b9e1333a99..d3cc61ce3f 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -725,7 +725,7 @@ (out-marshaled set-bang-type-num (cons undef-ok? (cons id rhs)) out)] - [(struct localref (unbox? offset clear? other-clears? flonum?)) + [(struct localref (unbox? offset clear? other-clears? type)) (if (and (not clear?) (not other-clears?) (not flonum?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) (out-byte (+ (if unbox? @@ -735,17 +735,16 @@ out) (begin (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears? flonum?)) + (if (not (or clear? other-clears? type)) (out-number offset out) (begin (out-number (- (add1 offset)) out) - (out-number (if clear? - #x1 - (if other-clears? - #x2 - (if flonum? - #x3 - 0))) + (out-number (cond + [clear? 1] + [other-clears? 2] + [else (+ 2 (case type + [(flonum) 1] + [(fixnum) 2]))]) out)))))] [(? lam?) (out-lam v out)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 18e7426b01..63b964fb19 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -88,6 +88,7 @@ (define CLOS_IS_METHOD 16) (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) + (define BITS_PER_ARG 4) (match v [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) @@ -95,31 +96,32 @@ (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (values (vector-length v) v rest) (values v (car rest) (cdr rest)))] - [(check-bit) (lambda (i) + [(get-flags) (lambda (i) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) 0 (let ([byte (vector-ref closed-over - (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) - (+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) - 1 - 0) - (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) - 2 - 0)))))] + (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) + (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) + (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] + [(num->type) (lambda (n) + (case n + [(2) 'flonum] + [(3) 'fixnum] + [else (error "invaid type flag")]))] [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) (for/list ([i (in-range num-params)]) - (case (check-bit i) + (define v (get-flags i)) + (case v [(0) 'val] [(1) 'ref] - [(2) 'flonum] - [else (error "both 'ref and 'flonum argument?")])))] + [else (num->type v)])))] [(closure-types) (for/list ([i (in-range closure-size)] [j (in-naturals num-params)]) - (case (check-bit j) + (define v (get-flags j)) + (case v [(0) 'val/ref] [(1) (error "invalid 'ref closure variable")] - [(2) 'flonum] - [else (error "both 'ref and 'flonum closure var?")]))]) + [else (num->type v)]))]) (make-lam name (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) @@ -467,7 +469,7 @@ [16 vector] [17 hash-table] [18 stx] - [19 let-one-flonum] + [19 let-one-typed] [20 marshalled] [21 quote] [22 reference] @@ -550,14 +552,21 @@ [reader (get-reader type)]) (reader l))) +(define SCHEME_LOCAL_TYPE_FLONUM 1) +(define SCHEME_LOCAL_TYPE_FIXNUM 2) + (define (make-local unbox? pos flags) - (define SCHEME_LOCAL_CLEAR_ON_READ #x01) - (define SCHEME_LOCAL_OTHER_CLEARS #x02) - (define SCHEME_LOCAL_FLONUM #x03) + (define SCHEME_LOCAL_CLEAR_ON_READ 1) + (define SCHEME_LOCAL_OTHER_CLEARS 2) + (define SCHEME_LOCAL_TYPE_OFFSET 2) (make-localref unbox? pos (= flags SCHEME_LOCAL_CLEAR_ON_READ) (= flags SCHEME_LOCAL_OTHER_CLEARS) - (= flags SCHEME_LOCAL_FLONUM))) + (let ([t (- flags SCHEME_LOCAL_TYPE_OFFSET)]) + (cond + [(= t SCHEME_LOCAL_TYPE_FLONUM) 'flonum] + [(= t SCHEME_LOCAL_TYPE_FIXNUM) 'fixnum] + [else #f])))) (define (a . << . b) (arithmetic-shift a b)) @@ -841,9 +850,13 @@ (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) (loop l ppr)))] - [(let-one let-one-flonum let-one-unused) + [(let-one let-one-typed let-one-unused) (make-let-one (read-compact cp) (read-compact cp) - (eq? cpt-tag 'let-one-flonum) + (and (eq? cpt-tag 'let-one-typed) + (case (read-compact-number cp) + [(1) 'flonum] + [(2) 'fixnum] + [else #f])) (eq? cpt-tag 'let-one-unused))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index a2aa9c284b..bdac336473 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -146,17 +146,20 @@ [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used 'sfs-clear-rest-args))] [num-params exact-nonnegative-integer?] - [param-types (listof (or/c 'val 'ref 'flonum))] + [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))] [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] - [closure-types (listof (or/c 'val/ref 'flonum))] + [closure-types (listof (or/c 'val/ref 'flonum 'fixnum))] [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))] [max-let-depth exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; `lambda' (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) (define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))])) -(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack +(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] ; pushes one value onto stack + [body (or/c expr? seq? any/c)] + [type (or/c #f 'flonum 'fixnum)] + [unused? boolean?])) (define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots (define-form-struct (install-value expr) ([count exact-nonnegative-integer?] [pos exact-nonnegative-integer?] @@ -166,7 +169,11 @@ (define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots (define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element -(define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack +(define-form-struct (localref expr) ([unbox? boolean?] + [pos exact-nonnegative-integer?] + [clear? boolean?] + [other-clears? boolean?] + [type (or/c #f 'flonum 'fixnum)])) ; access local via stack (define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) From bbc7d243e920dcfdbf0fecb312999b74cb2f55cd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 15 Nov 2012 05:21:42 -0700 Subject: [PATCH 280/466] fix compiler/zo-marshal Missed some updates for recent local-type changes. Also, fix up a few field names in the demodularizer. original commit: d7eddb91ef4c8058fd9bf4c329babe64510965c1 --- .../compiler/demodularizer/gc-toplevels.rkt | 8 ++-- .../demodularizer/update-toplevels.rkt | 6 +-- collects/compiler/zo-marshal.rkt | 41 ++++++++++++------- 3 files changed, 33 insertions(+), 22 deletions(-) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index ad8c74faee..a32f3857f1 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -138,7 +138,7 @@ (build-graph! lhs args-expr)] [(and f (struct primval (id))) (void)] - [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + [(and f (struct localref (unbox? pos clear? other-clears? type))) (void)] [(and v (not (? form?))) (void)])) @@ -223,8 +223,8 @@ [(and cl (struct case-lam (name clauses))) (struct-copy case-lam cl [clauses (map update clauses)])] - [(struct let-one (rhs body flonum? unused?)) - (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is flonum? okay here? + [(struct let-one (rhs body type unused?)) + (make-let-one (update rhs) (update body) type unused?)] [(and f (struct let-void (count boxes? body))) (struct-copy let-void f [body (update body)])] @@ -271,7 +271,7 @@ (update args-expr))] [(and f (struct primval (id))) f] - [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + [(and f (struct localref (unbox? pos clear? other-clears? type))) f] [(and v (not (? form?))) v] diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 6c1c83704e..c1701d5412 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -37,8 +37,8 @@ (map update clauses)) (struct-copy case-lam cl [clauses new-clauses])] - [(struct let-one (rhs body flonum? unused?)) - (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is it okay to just pass in the old value for flonum? + [(struct let-one (rhs body type unused?)) + (make-let-one (update rhs) (update body) type unused?)] [(and f (struct let-void (count boxes? body))) (struct-copy let-void f [body (update body)])] @@ -85,7 +85,7 @@ (update args-expr))] [(and f (struct primval (id))) f] - [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + [(and f (struct localref (unbox? pos clear? other-clears? type))) f] [(and f (not (? form?))) f] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index d3cc61ce3f..d5545c6300 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -317,7 +317,7 @@ CPT_VECTOR CPT_HASH_TABLE CPT_STX - CPT_LET_ONE_FLONUM + CPT_LET_ONE_TYPED CPT_MARSHALLED CPT_QUOTE CPT_REFERENCE @@ -370,6 +370,7 @@ (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) +(define BITS_PER_ARG 4) (define (int->bytes x) (integer->integer-bytes x @@ -579,6 +580,12 @@ (with-continuation-mark 'zo (typeof v) (begin0 (begin body ...) (void)))])) +(define (type->index type) + (case type + [(flonum) 1] + [(fixnum) 2] + [else (error 'type->index "unknown type: ~e" type)])) + (define (out-anything v out) (with-type-trace v (out-shared @@ -742,9 +749,7 @@ (out-number (cond [clear? 1] [other-clears? 2] - [else (+ 2 (case type - [(flonum) 1] - [(fixnum) 2]))]) + [else (+ 2 (type->index type))]) out)))))] [(? lam?) (out-lam v out)] @@ -753,14 +758,16 @@ (cons (or name null) lams) out)] - [(struct let-one (rhs body flonum? unused?)) + [(struct let-one (rhs body type unused?)) (out-byte (cond - [flonum? CPT_LET_ONE_FLONUM] + [type CPT_LET_ONE_TYPED] [unused? CPT_LET_ONE_UNUSED] [else CPT_LET_ONE]) out) (out-anything (protect-quote rhs) out) - (out-anything (protect-quote body) out)] + (out-anything (protect-quote body) out) + (when type + (out-number (type->index type) out))] [(struct let-void (count boxes? body)) (out-marshaled let-void-type-num (list* @@ -1099,8 +1106,8 @@ (match expr [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) (let* ([l (protect-quote body)] - [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) - (ormap (lambda (t) (memq t '(flonum))) closure-types))] + [any-refs? (or (not (andmap (lambda (t) (eq? t 'val)) param-types)) + (not (andmap (lambda (t) (eq? t 'val/ref)) closure-types)))] [num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags))) (add1 num-params) num-params)] @@ -1109,22 +1116,26 @@ (append (vector->list closure-map) (let* ([v (make-vector (ceiling - (/ (* 2 (+ num-params (vector-length closure-map))) + (/ (* BITS_PER_ARG (+ num-params (vector-length closure-map))) BITS_PER_MZSHORT)))] [set-bit! (lambda (i bit) - (let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) + (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)]) (vector-set! v pos (bitwise-ior (vector-ref v pos) (arithmetic-shift bit - (modulo (* 2 i) BITS_PER_MZSHORT))))))]) + (modulo (* BITS_PER_ARG i) BITS_PER_MZSHORT))))))]) (for ([t (in-list param-types)] [i (in-naturals)]) - (when (eq? t 'ref) (set-bit! i 1)) - (when (eq? t 'flonum) (set-bit! i 2))) + (case t + [(val) (void)] + [(ref) (set-bit! i 1)] + [else (set-bit! i (+ 1 (type->index t)))])) (for ([t (in-list closure-types)] [i (in-naturals num-all-params)]) - (when (eq? t 'flonum) (set-bit! i 2))) + (case t + [(val/ref) (void)] + [else (set-bit! i (+ 1 (type->index t)))])) (vector->list v)))) closure-map)) l)] From 3b9e13b38f8a29bbdc5436aea58dfdd44fa7f1d1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 18 Nov 2012 09:09:39 -0700 Subject: [PATCH 281/466] fix to bytecode compiler's propoagation of local-type info This is another old bug that could have caused validation failures with flonums, but it showed up with fixnum tracking because fixnums are more common (e.g., from `string-length'). There were really two bugs: information installed at the wrong offet in one place, and a failure to detect that information should be propagated in a different place. Fixing both avoids a validation problem with `html/sgml-reader'. original commit: afca33b78bf0abd1a7155657338109e9d6f3df51 --- collects/compiler/decompile.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 5ba6948567..cff6996930 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -326,7 +326,7 @@ [(struct topsyntax (depth pos midpt)) (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] [(struct primval (id)) - (hash-ref primitive-table id)] + (hash-ref primitive-table id (lambda () (error "unknown primitive")))] [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack closed) ,(decompile-expr rhs globs stack closed))] From 3c01f128b9446ff83eaa033f274023a5cb6b141c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 Jan 2013 09:02:23 -0700 Subject: [PATCH 282/466] raco exe: yet another submodule repair Closes PR 13410 original commit: e66cd6f9c74783592eae9a564dc19870e4520c6d --- collects/tests/racket/embed-asl.rkt | 4 +++ collects/tests/racket/embed-bsl.rkt | 4 +++ collects/tests/racket/embed-bsla.rkt | 4 +++ collects/tests/racket/embed-isl.rkt | 4 +++ collects/tests/racket/embed-isll.rkt | 4 +++ collects/tests/racket/embed.rktl | 49 +++++++++++++++++++++------- 6 files changed, 58 insertions(+), 11 deletions(-) create mode 100644 collects/tests/racket/embed-asl.rkt create mode 100644 collects/tests/racket/embed-bsl.rkt create mode 100644 collects/tests/racket/embed-bsla.rkt create mode 100644 collects/tests/racket/embed-isl.rkt create mode 100644 collects/tests/racket/embed-isll.rkt diff --git a/collects/tests/racket/embed-asl.rkt b/collects/tests/racket/embed-asl.rkt new file mode 100644 index 0000000000..14a2c20866 --- /dev/null +++ b/collects/tests/racket/embed-asl.rkt @@ -0,0 +1,4 @@ +;; The first three lines of this file were inserted by DrRacket. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-advanced-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +10 diff --git a/collects/tests/racket/embed-bsl.rkt b/collects/tests/racket/embed-bsl.rkt new file mode 100644 index 0000000000..2c8819a72f --- /dev/null +++ b/collects/tests/racket/embed-bsl.rkt @@ -0,0 +1,4 @@ +;; The first three lines of this file were inserted by DrRacket. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-beginner-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +10 diff --git a/collects/tests/racket/embed-bsla.rkt b/collects/tests/racket/embed-bsla.rkt new file mode 100644 index 0000000000..a8382c3bd6 --- /dev/null +++ b/collects/tests/racket/embed-bsla.rkt @@ -0,0 +1,4 @@ +;; The first three lines of this file were inserted by DrRacket. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-beginner-abbr-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +10 diff --git a/collects/tests/racket/embed-isl.rkt b/collects/tests/racket/embed-isl.rkt new file mode 100644 index 0000000000..ef27ea6de6 --- /dev/null +++ b/collects/tests/racket/embed-isl.rkt @@ -0,0 +1,4 @@ +;; The first three lines of this file were inserted by DrRacket. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-intermediate-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +10 diff --git a/collects/tests/racket/embed-isll.rkt b/collects/tests/racket/embed-isll.rkt new file mode 100644 index 0000000000..225485a486 --- /dev/null +++ b/collects/tests/racket/embed-isll.rkt @@ -0,0 +1,4 @@ +;; The first three lines of this file were inserted by DrRacket. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +10 diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index be3027b221..f84cf26392 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -45,7 +45,8 @@ (define (try-one-exe exe expect mred?) (printf "Running ~a\n" exe) (let ([plthome (getenv "PLTHOME")] - [collects (getenv "PLTCOLLECTS")]) + [collects (getenv "PLTCOLLECTS")] + [out (open-output-string)]) ;; Try to hide usual collections: (when plthome (putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) @@ -55,23 +56,29 @@ (parameterize ([current-directory (find-system-path 'temp-dir)]) (when (file-exists? "stdout") (delete-file "stdout")) - (test #t - system* (if (and mred? (eq? 'macosx (system-type))) - (let-values ([(base name dir?) (split-path exe)]) - (build-path exe "Contents" "MacOS" - (path-replace-suffix name #""))) - exe))) + (let ([path (if (and mred? (eq? 'macosx (system-type))) + (let-values ([(base name dir?) (split-path exe)]) + (build-path exe "Contents" "MacOS" + (path-replace-suffix name #""))) + exe)]) + (test #t + path + (parameterize ([current-output-port out]) + (system* path))))) (when plthome (putenv "PLTHOME" plthome)) (when collects (putenv "PLTCOLLECTS" collects)) - (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") - (lambda () (read-string 5000))))) - + (let ([stdout-file (build-path (find-system-path 'temp-dir) "stdout")]) + (if (file-exists? stdout-file) + (test expect with-input-from-file stdout-file + (lambda () (read-string 5000))) + (test expect get-output-string out))))) + (define (try-exe exe expect mred? [dist-hook void] #:dist? [dist? #t] . collects) (try-one-exe exe expect mred?) (when dist? - ;; Build a distirbution directory, and try that, too: + ;; Build a distribution directory, and try that, too: (printf " ... from distribution ...\n") (when (directory-exists? dist-dir) (delete-directory/files dist-dir)) @@ -522,12 +529,32 @@ ;; ---------------------------------------- +(define (try-*sl) + (define (try-one src) + (printf "Trying ~a...\n" src) + (define exe (path->string (mk-dest #f))) + (system* raco + "exe" + "-o" exe + "--" + (path->string (build-path (collection-path "tests" "racket") src))) + (try-exe exe "10\n" #f)) + + (try-one "embed-bsl.rkt") + (try-one "embed-bsla.rkt") + (try-one "embed-isl.rkt") + (try-one "embed-isll.rkt") + (try-one "embed-asl.rkt")) + +;; ---------------------------------------- + (try-basic) (try-mzc) (try-extension) (try-gracket) (try-reader) (try-planet) +(try-*sl) ;; ---------------------------------------- From ea00418cfe00df0e544e3abcb8da76bf46117cdc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 9 Jan 2013 07:59:47 -0700 Subject: [PATCH 283/466] Extending raco test to work on collections original commit: 3e0fff7dff8bc1b6bdd189dd52f3d5fab0ee9ae9 --- collects/compiler/commands/test.rkt | 60 +++++++++++++++++++++-------- 1 file changed, 44 insertions(+), 16 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 082b028536..6d6abb2b55 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -6,6 +6,7 @@ (define submodule 'test) (define run-anyways? #t) +(define collections? #f) (define (do-test e [check-suffix? #f]) (match e @@ -13,22 +14,46 @@ (do-test (string->path s))] [(? path? p) (cond - [(directory-exists? p) - (for-each - (λ (dp) + [(directory-exists? p) + (for-each + (λ (dp) (do-test (build-path p dp) #t)) - (directory-list p))] - [(and (file-exists? p) - (or (not check-suffix?) - (regexp-match #rx#"\\.rkt$" (path->bytes p)))) - (define mod `(submod ,p ,submodule)) - (cond - [(module-declared? mod #t) - (dynamic-require mod #f)] - [(and run-anyways? (module-declared? p #t)) - (dynamic-require p #f)])] - [(not (file-exists? p)) - (error 'test "Given path ~e does not exist" p)])])) + (directory-list p))] + [(and (file-exists? p) + (or (not check-suffix?) + (regexp-match #rx#"\\.rkt$" (path->bytes p)))) + (printf "testing ~a\n" p) + (define mod `(submod ,p ,submodule)) + (cond + [(module-declared? mod #t) + (dynamic-require mod #f)] + [(and run-anyways? (module-declared? p #t)) + (dynamic-require p #f)])] + [(not (file-exists? p)) + (error 'test "Given path ~e does not exist" p)])])) + +;; XXX This should be in Racket somewhere and return all the paths, +;; including the ones from the user and system collection links files (the system one is not specified in the docs, so I can't actually implement it correctly) +(define (all-library-collection-paths) + (find-library-collection-paths)) + +;; XXX This should be in Racket somewhere and return all the +;; collection paths, rather than just the first as collection-path +;; does. +;; +;; This implementation is wrong, btw, because it would ignore +;; collect-only links +(define (collection-paths c) + (for/list ([r (all-library-collection-paths)] + #:when (directory-exists? (build-path r c))) + (build-path r c))) + +(define (do-test-wrap e) + (cond + [collections? + (for-each do-test (collection-paths e))] + [else + (do-test e)])) (command-line #:program (short-program+command-name) @@ -42,5 +67,8 @@ [("--no-run-if-absent" "-x") "Require nothing if submodule is absent" (set! run-anyways? #f)] + [("--collection" "-c") + "Interpret arguments as collections" + (set! collections? #t)] #:args file-or-directory - (for-each do-test file-or-directory)) + (for-each do-test-wrap file-or-directory)) From 22acfa3cbad2f02be687bcc09d7abd8204a7d234 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 9 Jan 2013 08:12:56 -0700 Subject: [PATCH 284/466] test - Supporting packages in raco test original commit: 9015c15eec5a33783d4c0c6bd1b22f4852190b6e --- collects/compiler/commands/test.rkt | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 6d6abb2b55..320d97fbee 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -2,11 +2,11 @@ (require racket/cmdline racket/match racket/path - raco/command-name) + raco/command-name + planet2/lib) (define submodule 'test) (define run-anyways? #t) -(define collections? #f) (define (do-test e [check-suffix? #f]) (match e @@ -48,10 +48,28 @@ #:when (directory-exists? (build-path r c))) (build-path r c))) +(define collections? #f) +(define packages? #f) + (define (do-test-wrap e) (cond [collections? - (for-each do-test (collection-paths e))] + (match (collection-paths e) + [(list) + (error 'test "Collection ~e is not installed" e)] + [l + (for-each do-test l)])] + [packages? + (unless + (for*/or ([civs (in-list '(#t #f))] + [cisw (in-list '(#f #t))]) + (define pd + (parameterize ([current-install-version-specific? civs] + [current-install-system-wide? cisw]) + (with-handlers ([exn:fail? (λ (x) #f)]) + (package-directory e)))) + (and pd (do-test pd))) + (error 'test "Package ~e is not installed" e))] [else (do-test e)])) @@ -67,8 +85,12 @@ [("--no-run-if-absent" "-x") "Require nothing if submodule is absent" (set! run-anyways? #f)] + #:once-any [("--collection" "-c") "Interpret arguments as collections" (set! collections? #t)] + [("--package" "-p") + "Interpret arguments as packages" + (set! packages? #t)] #:args file-or-directory (for-each do-test-wrap file-or-directory)) From c13876971bbe09b7064dcc025295f0dda86abe5d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 10 Jan 2013 10:45:46 -0700 Subject: [PATCH 285/466] Working with links in collection testing original commit: 3312a8064d29e9118adf734ee7faced29c4a1a36 --- collects/compiler/commands/test.rkt | 59 ++++++++++++++++++++++------- 1 file changed, 45 insertions(+), 14 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 320d97fbee..1674a66e72 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -32,21 +32,52 @@ [(not (file-exists? p)) (error 'test "Given path ~e does not exist" p)])])) -;; XXX This should be in Racket somewhere and return all the paths, -;; including the ones from the user and system collection links files (the system one is not specified in the docs, so I can't actually implement it correctly) -(define (all-library-collection-paths) - (find-library-collection-paths)) +(module paths racket/base + (require setup/link + racket/list) -;; XXX This should be in Racket somewhere and return all the -;; collection paths, rather than just the first as collection-path -;; does. -;; -;; This implementation is wrong, btw, because it would ignore -;; collect-only links -(define (collection-paths c) - (for/list ([r (all-library-collection-paths)] - #:when (directory-exists? (build-path r c))) - (build-path r c))) + (struct col (name path) #:transparent) + + (define (get-linked user? version?) + (define version-re + (and version? + (regexp-quote (version)))) + (append + (for/list ([c+p (in-list (links #:user? user? #:version-regexp version-re #:with-path? #t))]) + (col (car c+p) + (cdr c+p))) + (for/list ([cp (in-list (links #:root? #t #:user? user? #:version-regexp version-re))] + #:when (directory-exists? cp) + [collection (directory-list cp)] + #:when (directory-exists? (build-path cp collection))) + (col (path->string collection) + (build-path cp collection))))) + + ;; A list of `col's, where each collection may be represented + ;; by multiple elements of the list, each with its own path. + (define (all-collections) + (remove-duplicates + (append* + (for/list ([cp (current-library-collection-paths)] + #:when (directory-exists? cp) + [collection (directory-list cp)] + #:when (directory-exists? (build-path cp collection))) + (col (path->string collection) + (build-path cp collection))) + (for*/list ([user? (in-list '(#t #f))] + [version? (in-list '(#t #f))]) + (get-linked user? version?))))) + + ;; This should be in Racket somewhere and return all the collection + ;; paths, rather than just the first as collection-path does. + (define (collection-paths c) + (for/list ([col (all-collections)] + #:when (string=? c (col-name col))) + (col-path col))) + + (provide collection-paths)) + +(require (submod "." paths)) (define collections? #f) (define packages? #f) From cb9baa4f4d2878c19a6067c3ede82c67f550c932 Mon Sep 17 00:00:00 2001 From: Michael Filonenko Date: Sun, 27 Jan 2013 14:03:36 -0700 Subject: [PATCH 286/466] extflonums An extflonum is like a flonum, but with 80-bit precision and not a number in the sense of `number?': only operations such as `extfl+' work on extflonums, and only on platforms where extflonums can be implemented by hardware without interefering with flonums (i.e., on platforms where SSE instructions are used for double-precision floats). [Patch provided by Michael Filonenko and revised by Matthew.] The compiler tracks information about bindings that are known to hold extflonums, but the JIT does not yet exploit this information to unbox them (except as intermediate results). original commit: 17b8092641b245caf77bfb6ac29b525995a7bfea --- collects/compiler/decompile.rkt | 1 + collects/compiler/zo-marshal.rkt | 1 + collects/compiler/zo-parse.rkt | 8 ++++++-- collects/compiler/zo-structs.rkt | 8 ++++---- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index cff6996930..6d5127cd50 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -19,6 +19,7 @@ (namespace-require ''#%kernel) (namespace-require ''#%unsafe) (namespace-require ''#%flfxnum) + (namespace-require ''#%extfl) (namespace-require ''#%futures) (for/list ([l (namespace-mapped-symbols)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index d5545c6300..450e8e78ea 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -584,6 +584,7 @@ (case type [(flonum) 1] [(fixnum) 2] + [(extflonum) 3] [else (error 'type->index "unknown type: ~e" type)])) (define (out-anything v out) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 63b964fb19..162391bff4 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -107,6 +107,7 @@ (case n [(2) 'flonum] [(3) 'fixnum] + [(4) 'extflonum] [else (error "invaid type flag")]))] [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) (for/list ([i (in-range num-params)]) @@ -373,8 +374,8 @@ [(27) 'inline-variant-type] [(35) 'variable-type] [(36) 'module-variable-type] - [(113) 'resolve-prefix-type] - [(162) 'free-id-info-type] + [(114) 'resolve-prefix-type] + [(164) 'free-id-info-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers @@ -554,6 +555,7 @@ (define SCHEME_LOCAL_TYPE_FLONUM 1) (define SCHEME_LOCAL_TYPE_FIXNUM 2) +(define SCHEME_LOCAL_TYPE_EXTFLONUM 3) (define (make-local unbox? pos flags) (define SCHEME_LOCAL_CLEAR_ON_READ 1) @@ -565,6 +567,7 @@ (let ([t (- flags SCHEME_LOCAL_TYPE_OFFSET)]) (cond [(= t SCHEME_LOCAL_TYPE_FLONUM) 'flonum] + [(= t SCHEME_LOCAL_TYPE_EXTFLONUM) 'extflonum] [(= t SCHEME_LOCAL_TYPE_FIXNUM) 'fixnum] [else #f])))) @@ -856,6 +859,7 @@ (case (read-compact-number cp) [(1) 'flonum] [(2) 'fixnum] + [(3) 'extflonum] [else #f])) (eq? cpt-tag 'let-one-unused))] [(branch) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index bdac336473..4ca4395d18 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -146,10 +146,10 @@ [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used 'sfs-clear-rest-args))] [num-params exact-nonnegative-integer?] - [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))] + [param-types (listof (or/c 'val 'ref 'flonum 'fixnum 'extflonum))] [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] - [closure-types (listof (or/c 'val/ref 'flonum 'fixnum))] + [closure-types (listof (or/c 'val/ref 'flonum 'fixnum 'extflonum))] [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))] [max-let-depth exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; `lambda' @@ -158,7 +158,7 @@ (define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] ; pushes one value onto stack [body (or/c expr? seq? any/c)] - [type (or/c #f 'flonum 'fixnum)] + [type (or/c #f 'flonum 'fixnum 'extflonum)] [unused? boolean?])) (define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots (define-form-struct (install-value expr) ([count exact-nonnegative-integer?] @@ -173,7 +173,7 @@ [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] - [type (or/c #f 'flonum 'fixnum)])) ; access local via stack + [type (or/c #f 'flonum 'fixnum 'extflonum)])) ; access local via stack (define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) From 06eb0e67e2013bfe9ae91caf227c4ab42979a8c0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 29 Jan 2013 05:53:05 -0700 Subject: [PATCH 287/466] repairs to extflonum changes original commit: 28493dcc880082afc0d8e2a6b69ed4c5f24c84bf --- collects/compiler/zo-marshal.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 450e8e78ea..e3333ba4ff 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -285,8 +285,8 @@ (define module-type-num 26) (define inline-variants-type-num 27) (define variable-type-num 35) -(define prefix-type-num 113) -(define free-id-info-type-num 162) +(define prefix-type-num 114) +(define free-id-info-type-num 164) (define-syntax define-enum (syntax-rules () From 81b3b3489588c948c173e5953efed5d34f481bf2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 3 Feb 2013 13:11:12 -0600 Subject: [PATCH 288/466] adjust raco test so that it accepts multiple -s arguments on the command-line This is, afaict, a completely backwards compatible way to add this functionality in the sense that any of the non-error command-line arguments passed to raco test before still do precisely the same things original commit: 9fd4698be9d7cd8d2779f5efae7d1a123e6e5c41 --- collects/compiler/commands/test.rkt | 37 +++++++++++++++++++---------- 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 1674a66e72..ecda02cfe2 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -5,8 +5,9 @@ raco/command-name planet2/lib) -(define submodule 'test) +(define submodules '()) (define run-anyways? #t) +(define quiet? #f) (define (do-test e [check-suffix? #f]) (match e @@ -22,15 +23,22 @@ [(and (file-exists? p) (or (not check-suffix?) (regexp-match #rx#"\\.rkt$" (path->bytes p)))) - (printf "testing ~a\n" p) - (define mod `(submod ,p ,submodule)) - (cond - [(module-declared? mod #t) - (dynamic-require mod #f)] - [(and run-anyways? (module-declared? p #t)) - (dynamic-require p #f)])] + (define something-wasnt-declared? #f) + (unless quiet? + (printf "testing ~a\n" p)) + (for ([submodule (in-list (if (null? submodules) + '(test) + (reverse submodules)))]) + (define mod `(submod ,p ,submodule)) + (cond + [(module-declared? mod #t) + (dynamic-require mod #f)] + [else + (set! something-wasnt-declared? #t)])) + (when (and run-anyways? something-wasnt-declared?) + (dynamic-require p #f))] [(not (file-exists? p)) - (error 'test "Given path ~e does not exist" p)])])) + (error 'test "given path ~e does not exist" p)])])) (module paths racket/base (require setup/link @@ -106,16 +114,21 @@ (command-line #:program (short-program+command-name) - #:once-each + #:multi [("--submodule" "-s") name - "Runs submodule (defaults to `test')" - (set! submodule (string->symbol name))] + "Runs submodule \n (defaults to running just the `test' submodule)" + (let ([n (string->symbol name)]) + (set! submodules (cons n submodules)))] + #:once-each [("--run-if-absent" "-r") "Require module if submodule is absent (on by default)" (set! run-anyways? #t)] [("--no-run-if-absent" "-x") "Require nothing if submodule is absent" (set! run-anyways? #f)] + [("--quiet" "-q") + "Suppress `Running ...' message" + (set! quiet? #t)] #:once-any [("--collection" "-c") "Interpret arguments as collections" From 80dd8d58f75b4b6c8cfa8f7b1de1281d5f02406e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 3 Feb 2013 15:31:09 -0600 Subject: [PATCH 289/466] change printouts from raco test to be slightly more informative original commit: 44e91ea961a3807d211ad05183f999f4cec881a1 --- collects/compiler/commands/test.rkt | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index ecda02cfe2..db7ea32d9c 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -24,18 +24,25 @@ (or (not check-suffix?) (regexp-match #rx#"\\.rkt$" (path->bytes p)))) (define something-wasnt-declared? #f) - (unless quiet? - (printf "testing ~a\n" p)) (for ([submodule (in-list (if (null? submodules) '(test) (reverse submodules)))]) (define mod `(submod ,p ,submodule)) (cond [(module-declared? mod #t) + (unless quiet? + (printf "running ~s:\n" `(submod ,(if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)) + ,submodule))) (dynamic-require mod #f)] [else (set! something-wasnt-declared? #t)])) (when (and run-anyways? something-wasnt-declared?) + (unless quiet? + (printf "running ~s:\n" (if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)))) (dynamic-require p #f))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)])])) From 55edebebbdb8277b7ada7542119f2ca221109aaa Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 4 Feb 2013 20:37:40 -0600 Subject: [PATCH 290/466] adjust raco test so it test the command-line arguments to the empty vector before running anything original commit: 2b7c6e32a9c529ddcdeac58cbb4f652f9f76e164 --- collects/compiler/commands/test.rkt | 43 +++++++++++++++-------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index db7ea32d9c..f4bf5bd9a5 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -23,27 +23,28 @@ [(and (file-exists? p) (or (not check-suffix?) (regexp-match #rx#"\\.rkt$" (path->bytes p)))) - (define something-wasnt-declared? #f) - (for ([submodule (in-list (if (null? submodules) - '(test) - (reverse submodules)))]) - (define mod `(submod ,p ,submodule)) - (cond - [(module-declared? mod #t) - (unless quiet? - (printf "running ~s:\n" `(submod ,(if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)) - ,submodule))) - (dynamic-require mod #f)] - [else - (set! something-wasnt-declared? #t)])) - (when (and run-anyways? something-wasnt-declared?) - (unless quiet? - (printf "running ~s:\n" (if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)))) - (dynamic-require p #f))] + (parameterize ([current-command-line-arguments '#()]) + (define something-wasnt-declared? #f) + (for ([submodule (in-list (if (null? submodules) + '(test) + (reverse submodules)))]) + (define mod `(submod ,p ,submodule)) + (cond + [(module-declared? mod #t) + (unless quiet? + (printf "running ~s:\n" `(submod ,(if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)) + ,submodule))) + (dynamic-require mod #f)] + [else + (set! something-wasnt-declared? #t)])) + (when (and run-anyways? something-wasnt-declared?) + (unless quiet? + (printf "running ~s:\n" (if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)))) + (dynamic-require p #f)))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)])])) From cde0a287792a8d8d42a573b45a6d0bf51b0c8042 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 6 Feb 2013 18:07:20 +0100 Subject: [PATCH 291/466] make `raco test' more like `racket' Instad of `(dynamic-require .. #f)', use `(dynamic-require .. 0)', which has the effect of making compile-time code "available" (see docs) in case the loaded module uses `eval' on syntax objects that refer to non-kernel syntax. original commit: 0aaf6b80863e16f2070734113e8bb35e2bbcf1b6 --- collects/compiler/commands/test.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index f4bf5bd9a5..ebe3f56e6f 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -36,7 +36,7 @@ `(file ,(path->string p)) (path->string p)) ,submodule))) - (dynamic-require mod #f)] + (dynamic-require mod 0)] [else (set! something-wasnt-declared? #t)])) (when (and run-anyways? something-wasnt-declared?) @@ -44,7 +44,7 @@ (printf "running ~s:\n" (if (absolute-path? p) `(file ,(path->string p)) (path->string p)))) - (dynamic-require p #f)))] + (dynamic-require p 0)))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)])])) From 12592019cd86feeb140b6d3546b338d580658e0f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 7 Feb 2013 06:57:53 -0600 Subject: [PATCH 292/466] change raco test's announcements to say "raco test" original commit: 7750cf9800570905e6ed8c976da24fee94a4310f --- collects/compiler/commands/test.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index ebe3f56e6f..90dd8f848e 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -32,18 +32,18 @@ (cond [(module-declared? mod #t) (unless quiet? - (printf "running ~s:\n" `(submod ,(if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)) - ,submodule))) + (printf "raco test ~s:\n" `(submod ,(if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)) + ,submodule))) (dynamic-require mod 0)] [else (set! something-wasnt-declared? #t)])) (when (and run-anyways? something-wasnt-declared?) (unless quiet? - (printf "running ~s:\n" (if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)))) + (printf "raco test ~s:\n" (if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)))) (dynamic-require p 0)))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)])])) From 0deb045dde0c21c4b8ad3d9d5e563337582c73ad Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 7 Feb 2013 10:15:02 -0600 Subject: [PATCH 293/466] tweak raco test output, yet again original commit: 86b1f276eb157e6f54670c49b5a21b244275a208 --- collects/compiler/commands/test.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 90dd8f848e..ad51c0b6e4 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -32,7 +32,7 @@ (cond [(module-declared? mod #t) (unless quiet? - (printf "raco test ~s:\n" `(submod ,(if (absolute-path? p) + (printf "raco test: ~s\n" `(submod ,(if (absolute-path? p) `(file ,(path->string p)) (path->string p)) ,submodule))) @@ -41,7 +41,7 @@ (set! something-wasnt-declared? #t)])) (when (and run-anyways? something-wasnt-declared?) (unless quiet? - (printf "raco test ~s:\n" (if (absolute-path? p) + (printf "raco test: ~s\n" (if (absolute-path? p) `(file ,(path->string p)) (path->string p)))) (dynamic-require p 0)))] From e97bb74005ba4eece8c4a2f3e4ec3b586a981d0c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Feb 2013 14:14:52 -0700 Subject: [PATCH 294/466] add experimental support for "phaseless" modules The intent is to support phase-crossing data such as the `exn:fail:syntax' structure type that is instantiaed by macros and recognized by contexts that use `eval' or `expand'. Phaseless modules are highly constrained, however, to avoid new cross-phase channels, and a module is inferred to be phaseless when it fits syntactic constraints. I've adjusted `racket/kernel' and improved its documentation a little so that it can be used to implement a phaseless module (which can import only from other phaseless modules). This change also adds a `flags' field to the `mod' structure type from `compiler/zo-structs'. original commit: 899a3279c2f37665b623a34414dc9c421e4b531e --- collects/compiler/decompile.rkt | 3 ++- collects/compiler/demodularizer/merge.rkt | 2 +- collects/compiler/demodularizer/module.rkt | 1 + collects/compiler/demodularizer/nodep.rkt | 4 ++-- collects/compiler/zo-marshal.rkt | 3 ++- collects/compiler/zo-parse.rkt | 3 ++- collects/compiler/zo-structs.rkt | 1 + 7 files changed, 11 insertions(+), 6 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 6d5127cd50..33d314ebb1 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -185,11 +185,12 @@ (define (decompile-module mod-form orig-stack stx-ht mod-name) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info internal-context pre-submodules post-submodules)) + max-let-depth dummy lang-info internal-context flags pre-submodules post-submodules)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [(stack) (append '(#%modvars) orig-stack)] [(closed) (make-hasheq)]) `(,mod-name ,(if (symbol? name) name (last name)) .... + ,@(if (null? flags) '() (list `(quote ,@flags))) ,@(let ([l (apply append (for/list ([req (in-list requires)] diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index f118e6b9e4..4ca7184e59 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -114,7 +114,7 @@ (match mod-form [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies unexported mod-max-let-depth dummy lang-info internal-context - pre-submodules post-submodules)) + flags pre-submodules post-submodules)) (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index dca4498fec..1be8d31309 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -34,6 +34,7 @@ lang-info #t empty + empty empty))])) (provide/contract diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index f6c70e2bb1..16d705cfca 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -137,7 +137,7 @@ (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context - pre-submodules post-submodules)) + flags pre-submodules post-submodules)) (define new-prefix prefix) ; Cache all the mpi paths (for-each (match-lambda @@ -154,7 +154,7 @@ (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now (list (make-mod name srcname self-modidx new-prefix provides requires body empty unexported max-let-depth dummy lang-info internal-context - empty empty))) + empty empty empty))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] [else (error 'nodep-module "huh?: ~e" mod-form)])) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e3333ba4ff..a8b787c08f 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -995,7 +995,7 @@ (define (convert-module mod-form) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info internal-context pre-submodules post-submodules)) + max-let-depth dummy lang-info internal-context flags pre-submodules post-submodules)) (let* ([lookup-req (lambda (phase) (let ([a (assq phase requires)]) (if a @@ -1091,6 +1091,7 @@ [l (cons lang-info l)] ; lang-info [l (cons (map convert-module post-submodules) l)] [l (cons (map convert-module pre-submodules) l)] + [l (cons (if (memq 'phaseless flags) #t #f) l)] [l (cons self-modidx l)] [l (cons srcname l)] [l (cons (if (pair? name) (car name) name) l)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 162391bff4..4aaf58de45 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -251,7 +251,7 @@ (define (read-module v) (match v [`(,submod-path - ,name ,srcname ,self-modidx + ,name ,srcname ,self-modidx ,phaseless? ,pre-submods ,post-submods ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy @@ -337,6 +337,7 @@ dummy lang-info rename + (if phaseless? '(phaseless) '()) (map read-module pre-submods) (map read-module post-submods))]))])) (define (read-module-wrap v) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 4ca4395d18..78fa6e2de9 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -139,6 +139,7 @@ [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] [internal-context (or/c #f #t stx? (vectorof stx?))] + [flags (listof (or/c 'phaseless))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) From d728e9118d42f0c6b7a46c292a6ecbc42d6b59e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Feb 2013 18:36:06 -0700 Subject: [PATCH 295/466] try "phase-collapsing" instead of "phaseless" original commit: 2646ff6895caf24f3517a5dd654ea6280d3aefe0 --- collects/compiler/zo-marshal.rkt | 2 +- collects/compiler/zo-parse.rkt | 4 ++-- collects/compiler/zo-structs.rkt | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index a8b787c08f..60c79b7120 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1091,7 +1091,7 @@ [l (cons lang-info l)] ; lang-info [l (cons (map convert-module post-submodules) l)] [l (cons (map convert-module pre-submodules) l)] - [l (cons (if (memq 'phaseless flags) #t #f) l)] + [l (cons (if (memq 'phase-collapsing flags) #t #f) l)] [l (cons self-modidx l)] [l (cons srcname l)] [l (cons (if (pair? name) (car name) name) l)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 4aaf58de45..7af7b06604 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -251,7 +251,7 @@ (define (read-module v) (match v [`(,submod-path - ,name ,srcname ,self-modidx ,phaseless? + ,name ,srcname ,self-modidx ,phase-collapsing? ,pre-submods ,post-submods ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy @@ -337,7 +337,7 @@ dummy lang-info rename - (if phaseless? '(phaseless) '()) + (if phase-collapsing? '(phase-collapsing) '()) (map read-module pre-submods) (map read-module post-submods))]))])) (define (read-module-wrap v) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 78fa6e2de9..f8a392e10c 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -139,7 +139,7 @@ [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] [internal-context (or/c #f #t stx? (vectorof stx?))] - [flags (listof (or/c 'phaseless))] + [flags (listof (or/c 'phase-collapsing))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) From 02fb754facb4df50422c941c7af6337f6296a8f9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 27 Feb 2013 07:48:25 -0700 Subject: [PATCH 296/466] minor decompiler tweak original commit: a46849f3b9a0c1350f356d0fb81599fb4991ebd7 --- collects/compiler/decompile.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 33d314ebb1..3edead45c4 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -190,7 +190,7 @@ [(stack) (append '(#%modvars) orig-stack)] [(closed) (make-hasheq)]) `(,mod-name ,(if (symbol? name) name (last name)) .... - ,@(if (null? flags) '() (list `(quote ,@flags))) + ,@(if (null? flags) '() (list `(quote ,flags))) ,@(let ([l (apply append (for/list ([req (in-list requires)] From bd39158cab325c42e5f3e013ef3426f4dc43af95 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 27 Feb 2013 08:20:32 -0700 Subject: [PATCH 297/466] terminology change again: "cross-phases persistent" modules original commit: 88a36a077c39c09eaa2ee7ae2e00647e667eaf71 --- collects/compiler/zo-marshal.rkt | 2 +- collects/compiler/zo-parse.rkt | 4 ++-- collects/compiler/zo-structs.rkt | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 60c79b7120..8b17d1178c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1091,7 +1091,7 @@ [l (cons lang-info l)] ; lang-info [l (cons (map convert-module post-submodules) l)] [l (cons (map convert-module pre-submodules) l)] - [l (cons (if (memq 'phase-collapsing flags) #t #f) l)] + [l (cons (if (memq 'cross-phase flags) #t #f) l)] [l (cons self-modidx l)] [l (cons srcname l)] [l (cons (if (pair? name) (car name) name) l)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 7af7b06604..0d21c1fd06 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -251,7 +251,7 @@ (define (read-module v) (match v [`(,submod-path - ,name ,srcname ,self-modidx ,phase-collapsing? + ,name ,srcname ,self-modidx ,cross-phase? ,pre-submods ,post-submods ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy @@ -337,7 +337,7 @@ dummy lang-info rename - (if phase-collapsing? '(phase-collapsing) '()) + (if cross-phase? '(cross-phase) '()) (map read-module pre-submods) (map read-module post-submods))]))])) (define (read-module-wrap v) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index f8a392e10c..1221cdad02 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -139,7 +139,7 @@ [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] [internal-context (or/c #f #t stx? (vectorof stx?))] - [flags (listof (or/c 'phase-collapsing))] + [flags (listof (or/c 'cross-phase))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) From caa7435c1a16fc8c69917518a7587613a53aaf1a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 Mar 2013 07:15:43 -0400 Subject: [PATCH 298/466] Fix lots of indentation mistakes. (Found by my ayatollah script...) original commit: af6be85ff576e475753a46bd3f1690eb8bf88a28 --- collects/compiler/demodularizer/merge.rkt | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 4ca7184e59..6edd751cb7 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -134,18 +134,18 @@ (list-ref toplevel-remap n))) (unless (= (length toplevel-remap) (length mod-toplevels)) - (error 'merge-module "Not remapping everything: ~S ~S" - mod-toplevels toplevel-remap)) + (error 'merge-module "Not remapping everything: ~S ~S" + mod-toplevels toplevel-remap)) (log-debug (format "[~S] Incrementing toplevels by ~a" - name - toplevel-offset)) + name + toplevel-offset)) (log-debug (format "[~S] Incrementing lifts by ~a" - name - lift-offset)) + name + lift-offset)) (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" - name - (length mod-toplevels) - (length new-mod-toplevels))) + name + (length mod-toplevels) + (length new-mod-toplevels))) (values (max max-let-depth mod-max-let-depth) (merge-prefix top-prefix new-mod-prefix) (lambda (top-prefix) From 8bde42b9d5a862f7a368171787819c5bf1eab671 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 21 Mar 2013 07:02:43 -0600 Subject: [PATCH 299/466] Adding test logging facility to rackunit and eli-tester, with its own test and docs original commit: 804791b01153b24c9b14d978243fb4c46c7c5601 --- collects/compiler/commands/test.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index ad51c0b6e4..a0b432ce2f 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -3,6 +3,7 @@ racket/match racket/path raco/command-name + rackunit/log planet2/lib) (define submodules '()) @@ -145,4 +146,5 @@ "Interpret arguments as packages" (set! packages? #t)] #:args file-or-directory - (for-each do-test-wrap file-or-directory)) + (begin (for-each do-test-wrap file-or-directory) + (test-log #:display? #t #:exit? #t))) From ab3a963a1ba8bd17a71d1fa86ab1950820cfec04 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 22 Mar 2013 07:19:09 -0600 Subject: [PATCH 300/466] Removing the planet2 name from the code original commit: 9f337c632ae0706b5619259a2b17f5257df1a24c --- collects/compiler/commands/test.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index a0b432ce2f..576316fe16 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -4,7 +4,7 @@ racket/path raco/command-name rackunit/log - planet2/lib) + pkg/lib) (define submodules '()) (define run-anyways? #t) From 77833ba35b85006e338cb1ce51a7b22089e9886a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Apr 2013 07:08:20 -0600 Subject: [PATCH 301/466] pkg/lib: clean up names and package-scope parameter More consistent exported names and parameters that better match the three scope choices (installation, user, or shared) --- cleaning up after myself. original commit: 267ac03279737cc7c819dfb9d404d389f56f2ea8 --- collects/compiler/commands/test.rkt | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 576316fe16..c42a5eabb4 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -108,15 +108,12 @@ [l (for-each do-test l)])] [packages? - (unless - (for*/or ([civs (in-list '(#t #f))] - [cisw (in-list '(#f #t))]) - (define pd - (parameterize ([current-install-version-specific? civs] - [current-install-system-wide? cisw]) - (with-handlers ([exn:fail? (λ (x) #f)]) - (package-directory e)))) - (and pd (do-test pd))) + (unless (for*/or ([scope (in-list '(installation user shared))]) + (define pd + (parameterize ([current-pkg-scope scope]) + (with-handlers ([exn:fail? (λ (x) #f)]) + (pkg-directory e)))) + (and pd (do-test pd))) (error 'test "Package ~e is not installed" e))] [else (do-test e)])) From 4af90112d0973477ef45dae8a54aeebf2d954df1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Apr 2013 08:49:22 -0600 Subject: [PATCH 302/466] pkg/lib: lock clean-up, and add `path->pkg' Make the installed-package database lock reentrant, change some functions to take the lock, and fix the documentation on when a lock is expected to be taken outside of functions. original commit: 10e53e3bf4e18d40f97213911b0b9c8bb56fd09f --- collects/compiler/commands/test.rkt | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index c42a5eabb4..381498b9ff 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -108,13 +108,10 @@ [l (for-each do-test l)])] [packages? - (unless (for*/or ([scope (in-list '(installation user shared))]) - (define pd - (parameterize ([current-pkg-scope scope]) - (with-handlers ([exn:fail? (λ (x) #f)]) - (pkg-directory e)))) - (and pd (do-test pd))) - (error 'test "Package ~e is not installed" e))] + (define pd (pkg-directory e)) + (if pd + (do-test pd) + (error 'test "Package ~e is not installed" e))] [else (do-test e)])) From cdbe3e0aafd2716fcc10704032997943755e533d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Apr 2013 10:08:27 -0600 Subject: [PATCH 303/466] raco setup: --tidy mode (as needed by `raco pkg remove') and more When a collection disappears, then documentation and metadata cross-references need fixing up based on everything that remains available, even though other setup actions are confined to collections that are specifically relevant to the packages. The new `--tidy' mode takes care of that. Package installation now also provides `--avoid-main' when working with packages in a scope other than installation scope, and `raco setup' now better respects `--avoid-main' to avoid creating executables or re-running documentation. Also, revise the `raco' documentation to better orient it toward the package manager. original commit: 51d48f3ab459475db5aa15966e28e51a4aba2d49 --- collects/setup/option-sig.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/setup/option-sig.rkt b/collects/setup/option-sig.rkt index 00e9f426bd..f545cca0b4 100644 --- a/collects/setup/option-sig.rkt +++ b/collects/setup/option-sig.rkt @@ -11,6 +11,7 @@ compiler-verbose clean compile-mode + make-only make-zo make-info-domain make-launchers @@ -18,6 +19,7 @@ make-user make-planet avoid-main-installation + make-tidy call-install call-post-install pause-on-errors From 58ce10c2ee27e6db779322c2edca99fa748f485e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Apr 2013 12:11:23 -0600 Subject: [PATCH 304/466] demote some `raco' commands The commands `link', `pack', and `unpack' are now discouraged in favor of `pkg'. original commit: 3e1ecc41b442f127c61d262a6df3811a746c16ec --- collects/compiler/commands/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 3fb1709547..6faf16eb19 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -3,7 +3,7 @@ (define raco-commands '(("make" compiler/commands/make "compile source to bytecode" 100) ("exe" compiler/commands/exe "create executable" 20) - ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) + ("pack" compiler/commands/pack "pack files/collections into a .plt archive" #f) ("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" #f) ("decompile" compiler/commands/decompile "decompile bytecode" #f) ("test" compiler/commands/test "run tests associated with files/directories" 15) From 45310eee82e2c7fbeecb05e04e25107ede2bc276 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 20 Apr 2013 00:59:51 -0400 Subject: [PATCH 305/466] raco test: make `-r' and `-x' mutually exclusive. original commit: 02d7f58cc16bb71a9955e835986767e219c53f9d --- collects/compiler/commands/test.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index 381498b9ff..dbbdc07445 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -122,13 +122,14 @@ "Runs submodule \n (defaults to running just the `test' submodule)" (let ([n (string->symbol name)]) (set! submodules (cons n submodules)))] - #:once-each + #:once-any [("--run-if-absent" "-r") "Require module if submodule is absent (on by default)" (set! run-anyways? #t)] [("--no-run-if-absent" "-x") "Require nothing if submodule is absent" (set! run-anyways? #f)] + #:once-each [("--quiet" "-q") "Suppress `Running ...' message" (set! quiet? #t)] From 072bc1110c046d367f5676fe27eba09278eb6723 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 May 2013 11:35:30 -0600 Subject: [PATCH 306/466] raco setup: add --doc-index; raco pkg: use --doc-index This combination of changes moves the decision about rebuilding "scribblings/main" and "scribblings/main/user" to `raco setup', which is in a better position to know whether documentation should be built at all. original commit: 413ca6843515dab5272d889e8a5f8df71fad9691 --- collects/setup/option-sig.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/setup/option-sig.rkt b/collects/setup/option-sig.rkt index f545cca0b4..d97ad6a660 100644 --- a/collects/setup/option-sig.rkt +++ b/collects/setup/option-sig.rkt @@ -20,6 +20,7 @@ make-planet avoid-main-installation make-tidy + make-doc-index call-install call-post-install pause-on-errors From bd9cf6061304f2cbf76bc311240f7f55879e8485 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 2 May 2013 14:49:31 -0600 Subject: [PATCH 307/466] Adding summary mode, quiet program mode and changing tests/eli-tester to cooperate so it adds useful information in summary mode original commit: ccf1119b68063306a5f749e7df9d275b33c3445b --- collects/compiler/commands/test.rkt | 154 ++++++++++++++++++++++------ 1 file changed, 122 insertions(+), 32 deletions(-) diff --git a/collects/compiler/commands/test.rkt b/collects/compiler/commands/test.rkt index dbbdc07445..b43c38f8f4 100644 --- a/collects/compiler/commands/test.rkt +++ b/collects/compiler/commands/test.rkt @@ -1,6 +1,10 @@ #lang racket/base (require racket/cmdline racket/match + racket/format + racket/list + racket/function + racket/port racket/path raco/command-name rackunit/log @@ -9,6 +13,76 @@ (define submodules '()) (define run-anyways? #t) (define quiet? #f) +(define quiet-program? #f) +(define table? #f) + +(define (dynamic-require* p d) + (parameterize + ([current-output-port + (if quiet-program? + (open-output-nowhere) + (current-output-port))] + [current-error-port + (if quiet-program? + (open-output-nowhere) + (current-error-port))]) + (dynamic-require p d))) + +(struct summary (failed total label body-res)) +(define-syntax-rule (with-summary label . body) + (let () + (match-define (cons before-failed before-total) + (test-log #:display? #f #:exit? #f)) + (define res (begin . body)) + (match-define (cons after-failed after-total) + (test-log #:display? #f #:exit? #f)) + (summary (- after-failed before-failed) + (- after-total before-total) + label + res))) + +(define (iprintf i fmt . more) + (for ([j (in-range i)]) + (display #\space)) + (apply printf fmt more)) +(define (display-summary top) + (define files + (let flatten ([sum top]) + (match sum + [(list sum ...) + (append-map flatten sum)] + [(summary failed total `(file ,p) body) + (list sum)] + [(summary failed total label body) + (flatten body)] + [(? void?) + empty]))) + (define sfiles + (sort files + (λ (x y) + (cond + [(= (summary-failed x) (summary-failed y)) + (> (summary-total x) (summary-total y))] + [else + (< (summary-failed x) (summary-failed y))])))) + (define (max-width f) + (string-length + (number->string + (apply max (map f sfiles))))) + (define failed-wid (max-width summary-failed)) + (define total-wid (max-width summary-total)) + (for ([f (in-list sfiles)]) + (match-define (summary failed total `(file ,p) _) f) + (displayln (~a (~a #:min-width failed-wid + #:align 'right + (if (zero? failed) + "" + failed)) + " " + (~a #:min-width total-wid + #:align 'right + total) + " " p)))) (define (do-test e [check-suffix? #f]) (match e @@ -17,35 +91,39 @@ [(? path? p) (cond [(directory-exists? p) - (for-each - (λ (dp) - (do-test (build-path p dp) #t)) - (directory-list p))] + (with-summary + `(directory ,p) + (map + (λ (dp) + (do-test (build-path p dp) #t)) + (directory-list p)))] [(and (file-exists? p) (or (not check-suffix?) (regexp-match #rx#"\\.rkt$" (path->bytes p)))) - (parameterize ([current-command-line-arguments '#()]) - (define something-wasnt-declared? #f) - (for ([submodule (in-list (if (null? submodules) - '(test) - (reverse submodules)))]) - (define mod `(submod ,p ,submodule)) - (cond - [(module-declared? mod #t) - (unless quiet? - (printf "raco test: ~s\n" `(submod ,(if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)) - ,submodule))) - (dynamic-require mod 0)] - [else - (set! something-wasnt-declared? #t)])) - (when (and run-anyways? something-wasnt-declared?) - (unless quiet? - (printf "raco test: ~s\n" (if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)))) - (dynamic-require p 0)))] + (with-summary + `(file ,p) + (parameterize ([current-command-line-arguments '#()]) + (define something-wasnt-declared? #f) + (for ([submodule (in-list (if (null? submodules) + '(test) + (reverse submodules)))]) + (define mod `(submod ,p ,submodule)) + (cond + [(module-declared? mod #t) + (unless quiet? + (printf "raco test: ~s\n" `(submod ,(if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)) + ,submodule))) + (dynamic-require* mod 0)] + [else + (set! something-wasnt-declared? #t)])) + (when (and run-anyways? something-wasnt-declared?) + (unless quiet? + (printf "raco test: ~s\n" (if (absolute-path? p) + `(file ,(path->string p)) + (path->string p)))) + (dynamic-require* p 0))))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)])])) @@ -106,12 +184,16 @@ [(list) (error 'test "Collection ~e is not installed" e)] [l - (for-each do-test l)])] + (with-summary + `(collection ,e) + (map do-test l))])] [packages? (define pd (pkg-directory e)) (if pd - (do-test pd) - (error 'test "Package ~e is not installed" e))] + (with-summary + `(package ,e) + (do-test pd)) + (error 'test "Package ~e is not installed" e))] [else (do-test e)])) @@ -131,8 +213,14 @@ (set! run-anyways? #f)] #:once-each [("--quiet" "-q") - "Suppress `Running ...' message" + "Suppress `raco test: ...' message" (set! quiet? #t)] + [("--table" "-t") + "Print a summary table" + (set! table? #t)] + [("--quiet-program" "-Q") + "Quiet the program" + (set! quiet-program? #t)] #:once-any [("--collection" "-c") "Interpret arguments as collections" @@ -141,5 +229,7 @@ "Interpret arguments as packages" (set! packages? #t)] #:args file-or-directory - (begin (for-each do-test-wrap file-or-directory) - (test-log #:display? #t #:exit? #t))) + (begin (define sum (map do-test-wrap file-or-directory)) + (when table? + (display-summary sum)) + (void (test-log #:display? #t #:exit? #t)))) From 0416b4a5ff21dc7ceb95e4a5c6384516d46c59d8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 3 May 2013 09:11:55 -0600 Subject: [PATCH 308/466] raco setup: allow foreign-lib and man-page installation This change hopefully fills out the things that a distribution can do and that packages should be able to extend. original commit: 03b35cd84689b5e37a1a3b51c0ceeba10c96f281 --- collects/setup/option-sig.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/setup/option-sig.rkt b/collects/setup/option-sig.rkt index d97ad6a660..aa4f6abb4c 100644 --- a/collects/setup/option-sig.rkt +++ b/collects/setup/option-sig.rkt @@ -14,6 +14,7 @@ make-only make-zo make-info-domain + make-foreign-libs make-launchers make-docs make-user From 8254cd3d9841c9537b3b7bbdad72e8dff45b6c9e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 5 May 2013 11:36:56 -0600 Subject: [PATCH 309/466] add `configure-runtime' submodule support A language can now introduce a `configure-runtime' submodule that is `dynamic-require'd before the enclosing module. This new submodule protocol provides a more general and easier-to-understand way of configuring the run-time environment for a module's language, as compared to the `module->language-info' path (through a `get-info' function, via a 'configure-runtime value, and finally loading the specified module). The `module->language-info' path remains in place, and it is checked after a `configure-runtime' submodule is run, since that order is likely to be the most backward compatible. original commit: 27f1b39294261eac3041c7d800eb33d19be36a23 --- collects/compiler/commands/exe.rkt | 19 +++++++++++++------ collects/tests/racket/embed-me22.rkt | 6 ++++++ collects/tests/racket/embed.rktl | 10 +++++++++- 3 files changed, 28 insertions(+), 7 deletions(-) create mode 100644 collects/tests/racket/embed-me22.rkt diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index 79254aa879..cdea3a3153 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -101,22 +101,29 @@ dest (exe-aux)))] [else + (define mod-sym (string->symbol + (format "#%mzc:~a" + (let-values ([(base name dir?) + (split-path source-file)]) + (path->bytes (path-replace-suffix name #"")))))) (mzc:create-embedding-executable dest #:mred? (gui) #:variant (if (3m) '3m 'cgc) #:verbose? (very-verbose) - #:modules (cons `(#%mzc: (file ,source-file) (main)) + #:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime)) (map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries))) #:configure-via-first-module? #t + #:early-literal-expressions + (parameterize ([current-namespace (make-base-namespace)]) + (define cr-sym (string->symbol (format "~a(configure-runtime)" mod-sym))) + (list + (compile + `(when (module-declared? '',cr-sym) + (dynamic-require '',cr-sym #f))))) #:literal-expression (parameterize ([current-namespace (make-base-namespace)]) - (define mod-sym (string->symbol - (format "#%mzc:~a" - (let-values ([(base name dir?) - (split-path source-file)]) - (path->bytes (path-replace-suffix name #"")))))) (define main-sym (string->symbol (format "~a(main)" mod-sym))) (compile `(begin diff --git a/collects/tests/racket/embed-me22.rkt b/collects/tests/racket/embed-me22.rkt new file mode 100644 index 0000000000..729a45a171 --- /dev/null +++ b/collects/tests/racket/embed-me22.rkt @@ -0,0 +1,6 @@ +#lang racket/kernel + +(printf "This is 22.\n") + +(module configure-runtime racket/kernel + (printf "Configure!\n")) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index f84cf26392..0a2527aa46 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -304,7 +304,15 @@ (path->string (build-path (collection-path "tests" "racket") "embed-me20.rkt"))) (try-exe (mk-dest mred?) "This is 20.\n" mred?) - ;;raco exe --launcher + ;; raco exe on a module with a `configure-runtime' submodule + (system* raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "racket") "embed-me22.rkt"))) + (try-exe (mk-dest mred?) "Configure!\nThis is 22.\n" mred?) + + ;; raco exe --launcher (system* raco "exe" "--launcher" From 28375134285f4c3cb45863b6a051527bdd6b2f96 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 May 2013 12:30:24 -0400 Subject: [PATCH 310/466] fix `raco exe' test original commit: b3e2d35be98c5c0a6ab4494070d539880bfad6fe --- collects/tests/racket/embed-me19.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/tests/racket/embed-me19.rkt b/collects/tests/racket/embed-me19.rkt index 158643bc6c..fcfda97e66 100644 --- a/collects/tests/racket/embed-me19.rkt +++ b/collects/tests/racket/embed-me19.rkt @@ -3,6 +3,7 @@ (define-runtime-module-path plai plai) (define-runtime-module-path plai-reader plai/lang/reader) +(define-runtime-module-path runtime racket/runtime-config) (parameterize ([read-accept-reader #t]) (namespace-require 'racket/base) From 4cdad9dec2f06e81f4118fbe787297eb4897d2b4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 May 2013 20:20:17 -0400 Subject: [PATCH 311/466] raco pkg create: support "source" and "binary" bundling Adds `--from-dir' and `--from-install' flags to select the interpretation of the argument as a directory or as the name of an installed package. Relevant to PR 13669 Adds `--as-is' (the default), `--source', and `--binary' flags to select a pruning mode. The `raco setup' tool recognizes a `rendered-scribblings' specification in "info.rkt" to trigger moving rendered documentation into place, registering its tags in the cross-reference database, and fixing up references to "local-redirect.js"; the presence of a "synced.rktd" indicates when those fixups have been performed (since, if the package is installed in a user-specific scope, the documentation doesn't actually move anywhere). Finally, "out.sxref" needs to report paths relative to the documentation's directory, and then the relative-directory references need to be suitably resolved at derserialization; some support for such relative paths was in place, but it wasn't quite general enough before. original commit: 198a65a5fc79649ec167d2407c35815768a119ba --- collects/tests/pkg/test-pkgs/pkg-z/info.rkt | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 collects/tests/pkg/test-pkgs/pkg-z/info.rkt diff --git a/collects/tests/pkg/test-pkgs/pkg-z/info.rkt b/collects/tests/pkg/test-pkgs/pkg-z/info.rkt new file mode 100644 index 0000000000..13a63c4835 --- /dev/null +++ b/collects/tests/pkg/test-pkgs/pkg-z/info.rkt @@ -0,0 +1,2 @@ +#lang setup/infotab + From f4abd52fa793a9d466c6254452f204b0e1dfd154 Mon Sep 17 00:00:00 2001 From: Kimball Germane Date: Mon, 10 Jun 2013 14:24:52 -0600 Subject: [PATCH 312/466] Language-level demodularizer. original commit: c9f4b96f884df6f95a22a8e4f808bfc91163a3c3 --- collects/compiler/demodularizer/batch.rkt | 79 ++--------------------- collects/compiler/demodularizer/main.rkt | 77 ++++++++++++++++++++++ 2 files changed, 84 insertions(+), 72 deletions(-) create mode 100644 collects/compiler/demodularizer/main.rkt diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index bd98894ad3..6ec08d76ec 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -39,80 +39,13 @@ Here's the idea: - Then, it will pay to do dead code elimination and inlining, etc. |# -(require racket/pretty - racket/system - racket/cmdline - "mpi.rkt" - "util.rkt" - "nodep.rkt" - "merge.rkt" - "gc-toplevels.rkt" - "alpha.rkt" - "module.rkt" - "replace-modidx.rkt" - compiler/decompile - compiler/zo-marshal +(require racket/cmdline racket/set - raco/command-name) - -(define (main file-to-batch output-file) - (define-values (base name dir?) (split-path file-to-batch)) - (when (or (eq? base #f) dir?) - (error 'batch "Cannot run on directory")) - - ;; Compile - - (log-info "Compiling module") - (void (system* (find-executable-path "raco") "make" file-to-batch)) - - (define merged-zo-path - (or output-file - (path-add-suffix file-to-batch #"_merged.zo"))) - - ;; Transformations - (define path-cache (make-hash)) - - (log-info "Removing dependencies") - (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) - (parameterize ([MODULE-PATHS path-cache]) - (nodep-file file-to-batch))) - - (log-info "Merging modules") - (define batch-merge - (parameterize ([MODULE-PATHS path-cache]) - (merge-compilation-top get-modvar-rewrite batch-nodep))) - - ; Not doing this for now - ;(log-info "GC-ing top-levels") - (define batch-gcd - batch-merge - #;(gc-toplevels batch-merge)) - - (log-info "Alpha-varying top-levels") - (define batch-alpha - (alpha-vary-ctop batch-gcd)) - - (log-info "Replacing self-modidx") - (define batch-replace-modidx - (replace-modidx batch-alpha top-self-modidx)) - - (define batch-modname - (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) - (log-info (format "Modularizing into ~a" batch-modname)) - (define batch-mod - (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) - - (log-info "Writing merged zo") - (void - (with-output-to-file - merged-zo-path - (lambda () - (zo-marshal-to batch-mod (current-output-port))) - #:exists 'replace))) + raco/command-name + "main.rkt") -(let () - (define output-file (make-parameter #f)) +(let ([output-file (make-parameter #f)]) (command-line #:program (short-program+command-name) #:multi [("-e" "--exclude-modules") path "Exclude from flattening" @@ -120,5 +53,7 @@ Here's the idea: #:once-each [("-o") dest-filename "Write output as " (output-file (string->path dest-filename))] + [("-g" "--garbage-collect") "Garbage-collect final module (unsound)" + (garbage-collect-toplevels-enabled #t)] #:args (filename) - (main filename (output-file)))) + (demodularize filename (output-file)))) diff --git a/collects/compiler/demodularizer/main.rkt b/collects/compiler/demodularizer/main.rkt new file mode 100644 index 0000000000..36e8a140fb --- /dev/null +++ b/collects/compiler/demodularizer/main.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require compiler/cm + compiler/zo-marshal + "alpha.rkt" + "gc-toplevels.rkt" + "merge.rkt" + "module.rkt" + "mpi.rkt" + "nodep.rkt" + "replace-modidx.rkt") + +(provide current-excluded-modules + garbage-collect-toplevels-enabled + demodularize) + +(define garbage-collect-toplevels-enabled (make-parameter #f)) + +(define logger (make-logger 'demodularizer (current-logger))) + +(define (demodularize file-to-batch [output-file #f]) + (parameterize ([current-logger logger]) + (define-values (base name must-be-dir?) (split-path file-to-batch)) + (when must-be-dir? + (error 'demodularize "Cannot run on directory: ~a" file-to-batch)) + (unless (file-exists? file-to-batch) + (error 'demodularize "File does not exist: ~a" file-to-batch)) + + ;; Compile + (log-info "Compiling module") + (parameterize ([current-namespace (make-base-empty-namespace)]) + (managed-compile-zo file-to-batch)) + + (define merged-zo-path + (or output-file + (path-add-suffix file-to-batch #"_merged.zo"))) + + ;; Transformations + (define path-cache (make-hash)) + + (log-info "Removing dependencies") + (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) + (parameterize ([MODULE-PATHS path-cache]) + (nodep-file file-to-batch))) + + (log-info "Merging modules") + (define batch-merge + (parameterize ([MODULE-PATHS path-cache]) + (merge-compilation-top get-modvar-rewrite batch-nodep))) + + (define batch-gcd + (if (garbage-collect-toplevels-enabled) + (begin + (log-info "GC-ing top-levels") + (gc-toplevels batch-merge)) + batch-merge)) + + (log-info "Alpha-varying top-levels") + (define batch-alpha + (alpha-vary-ctop batch-gcd)) + + (log-info "Replacing self-modidx") + (define batch-replace-modidx + (replace-modidx batch-alpha top-self-modidx)) + + (define batch-modname + (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) + (log-info (format "Modularizing into ~a" batch-modname)) + (define batch-mod + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) + + (log-info "Writing merged zo") + (void + (with-output-to-file + merged-zo-path + (lambda () + (zo-marshal-to batch-mod (current-output-port))) + #:exists 'replace)))) \ No newline at end of file From e828d319f88df97103095fde4d104625487c8797 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 May 2013 21:57:31 -0600 Subject: [PATCH 313/466] reorganize into core plus packages The "racket" directory contains a pared-back version of the repository, roughly. The "pkgs" directory everything else in the repository, but organized into packages. original commit: b2ebb0a28bf8136e75cd98316c22fe54c30eacb2 --- collects/meta/drdr2/analyzer/analyzer.rkt | 1 - {collects => pkgs/plt-services}/meta/drdr2/master/master.rkt | 0 .../pkg/test-pkgs/pkg-z => pkgs/racket-pkgs/at-exp-lib}/info.rkt | 1 - .../racket-pkgs/racket-test}/tests/compiler/collection-zos.rkt | 0 .../racket-test}/tests/compiler/demodularizer/demod-test.rkt | 0 .../racket-test}/tests/compiler/demodularizer/tests/kernel-5.rkt | 0 .../racket-test}/tests/compiler/demodularizer/tests/racket-5.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/regression.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/test/a.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/test/b.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/test/d/c.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/test/d/d.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/zo-exs.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/zo-test-util.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/zo-test-worker.rkt | 0 .../racket-pkgs/racket-test}/tests/compiler/zo-test.rkt | 0 {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/zo.rkt | 0 .../racket-test}/tests/racket/benchmarks/shootout/nothing.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/ctool.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-asl.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-bsl.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-bsla.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-isl.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-isll.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me1.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me10.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me11-rd.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me12-rd.ss | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me13.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me14.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me15-one.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me15.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me16.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me17.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me17a.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me18a.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me19.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me1b.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me1c.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me1d.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me1e.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me2.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me20.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me21.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me22.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me3.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me4.rktl | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me5.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me6.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me8.c | 0 .../racket-pkgs/racket-test}/tests/racket/embed-me9.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-place.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-planet-1/alt.rkt | 0 .../racket-test}/tests/racket/embed-planet-1/dyn-sub.rkt | 0 .../racket-test}/tests/racket/embed-planet-1/has-sub.rkt | 0 .../racket-test}/tests/racket/embed-planet-1/main.rkt | 0 .../racket-test}/tests/racket/embed-planet-1/other.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed-planet-2/main.ss | 0 .../racket-test}/tests/racket/embed-planet-2/private/sub.rkt | 0 .../racket-pkgs/racket-test}/tests/racket/embed.rktl | 0 {collects => racket/lib/collects}/compiler/bundle-dist.rkt | 0 .../lib/collects}/compiler/commands/decompile.rkt | 0 {collects => racket/lib/collects}/compiler/commands/exe-dir.rkt | 0 {collects => racket/lib/collects}/compiler/commands/exe.rkt | 0 {collects => racket/lib/collects}/compiler/commands/expand.rkt | 0 {collects => racket/lib/collects}/compiler/commands/info.rkt | 0 {collects => racket/lib/collects}/compiler/commands/make.rkt | 0 {collects => racket/lib/collects}/compiler/commands/pack.rkt | 0 {collects => racket/lib/collects}/compiler/commands/test.rkt | 0 {collects => racket/lib/collects}/compiler/commands/unpack.rkt | 0 {collects => racket/lib/collects}/compiler/decompile.rkt | 0 .../lib/collects}/compiler/demodularizer/alpha.rkt | 0 .../lib/collects}/compiler/demodularizer/batch.rkt | 0 .../lib/collects}/compiler/demodularizer/gc-toplevels.rkt | 0 .../lib/collects}/compiler/demodularizer/main.rkt | 0 .../lib/collects}/compiler/demodularizer/merge.rkt | 0 .../lib/collects}/compiler/demodularizer/module.rkt | 0 {collects => racket/lib/collects}/compiler/demodularizer/mpi.rkt | 0 .../lib/collects}/compiler/demodularizer/nodep.rkt | 0 .../lib/collects}/compiler/demodularizer/replace-modidx.rkt | 0 .../lib/collects}/compiler/demodularizer/update-toplevels.rkt | 0 .../lib/collects}/compiler/demodularizer/util.rkt | 0 {collects => racket/lib/collects}/compiler/embed-sig.rkt | 0 {collects => racket/lib/collects}/compiler/sig.rkt | 0 {collects => racket/lib/collects}/compiler/zo-marshal.rkt | 0 {collects => racket/lib/collects}/compiler/zo-parse.rkt | 0 {collects => racket/lib/collects}/compiler/zo-structs.rkt | 0 {collects => racket/lib/collects}/launcher/launcher-sig.rkt | 0 {collects => racket/lib/collects}/setup/option-sig.rkt | 0 89 files changed, 2 deletions(-) delete mode 100644 collects/meta/drdr2/analyzer/analyzer.rkt rename {collects => pkgs/plt-services}/meta/drdr2/master/master.rkt (100%) rename {collects/tests/pkg/test-pkgs/pkg-z => pkgs/racket-pkgs/at-exp-lib}/info.rkt (95%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/collection-zos.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/demodularizer/demod-test.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/demodularizer/tests/kernel-5.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/demodularizer/tests/racket-5.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/regression.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/test/a.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/test/b.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/test/d/c.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/test/d/d.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/zo-exs.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/zo-test-util.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/zo-test-worker.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/zo-test.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/compiler/zo.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/benchmarks/shootout/nothing.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/ctool.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-asl.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-bsl.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-bsla.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-isl.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-isll.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me1.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me10.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me11-rd.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me12-rd.ss (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me13.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me14.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me15-one.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me15.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me16.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me17.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me17a.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me18a.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me19.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me1b.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me1c.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me1d.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me1e.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me2.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me20.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me21.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me22.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me3.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me4.rktl (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me5.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me6.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me8.c (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-me9.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-place.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-planet-1/alt.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-planet-1/dyn-sub.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-planet-1/has-sub.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-planet-1/main.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-planet-1/other.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-planet-2/main.ss (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed-planet-2/private/sub.rkt (100%) rename {collects => pkgs/racket-pkgs/racket-test}/tests/racket/embed.rktl (100%) rename {collects => racket/lib/collects}/compiler/bundle-dist.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/decompile.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/exe-dir.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/exe.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/expand.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/info.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/make.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/pack.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/test.rkt (100%) rename {collects => racket/lib/collects}/compiler/commands/unpack.rkt (100%) rename {collects => racket/lib/collects}/compiler/decompile.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/alpha.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/batch.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/gc-toplevels.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/main.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/merge.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/module.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/mpi.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/nodep.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/replace-modidx.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/update-toplevels.rkt (100%) rename {collects => racket/lib/collects}/compiler/demodularizer/util.rkt (100%) rename {collects => racket/lib/collects}/compiler/embed-sig.rkt (100%) rename {collects => racket/lib/collects}/compiler/sig.rkt (100%) rename {collects => racket/lib/collects}/compiler/zo-marshal.rkt (100%) rename {collects => racket/lib/collects}/compiler/zo-parse.rkt (100%) rename {collects => racket/lib/collects}/compiler/zo-structs.rkt (100%) rename {collects => racket/lib/collects}/launcher/launcher-sig.rkt (100%) rename {collects => racket/lib/collects}/setup/option-sig.rkt (100%) diff --git a/collects/meta/drdr2/analyzer/analyzer.rkt b/collects/meta/drdr2/analyzer/analyzer.rkt deleted file mode 100644 index 6f1f7b4de3..0000000000 --- a/collects/meta/drdr2/analyzer/analyzer.rkt +++ /dev/null @@ -1 +0,0 @@ -#lang racket diff --git a/collects/meta/drdr2/master/master.rkt b/pkgs/plt-services/meta/drdr2/master/master.rkt similarity index 100% rename from collects/meta/drdr2/master/master.rkt rename to pkgs/plt-services/meta/drdr2/master/master.rkt diff --git a/collects/tests/pkg/test-pkgs/pkg-z/info.rkt b/pkgs/racket-pkgs/at-exp-lib/info.rkt similarity index 95% rename from collects/tests/pkg/test-pkgs/pkg-z/info.rkt rename to pkgs/racket-pkgs/at-exp-lib/info.rkt index 13a63c4835..c14a2ca411 100644 --- a/collects/tests/pkg/test-pkgs/pkg-z/info.rkt +++ b/pkgs/racket-pkgs/at-exp-lib/info.rkt @@ -1,2 +1 @@ #lang setup/infotab - diff --git a/collects/tests/compiler/collection-zos.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/collection-zos.rkt similarity index 100% rename from collects/tests/compiler/collection-zos.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/collection-zos.rkt diff --git a/collects/tests/compiler/demodularizer/demod-test.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt similarity index 100% rename from collects/tests/compiler/demodularizer/demod-test.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt diff --git a/collects/tests/compiler/demodularizer/tests/kernel-5.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/kernel-5.rkt similarity index 100% rename from collects/tests/compiler/demodularizer/tests/kernel-5.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/kernel-5.rkt diff --git a/collects/tests/compiler/demodularizer/tests/racket-5.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/racket-5.rkt similarity index 100% rename from collects/tests/compiler/demodularizer/tests/racket-5.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/racket-5.rkt diff --git a/collects/tests/compiler/regression.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/regression.rkt similarity index 100% rename from collects/tests/compiler/regression.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/regression.rkt diff --git a/collects/tests/compiler/test/a.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/test/a.rkt similarity index 100% rename from collects/tests/compiler/test/a.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/test/a.rkt diff --git a/collects/tests/compiler/test/b.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/test/b.rkt similarity index 100% rename from collects/tests/compiler/test/b.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/test/b.rkt diff --git a/collects/tests/compiler/test/d/c.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/test/d/c.rkt similarity index 100% rename from collects/tests/compiler/test/d/c.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/test/d/c.rkt diff --git a/collects/tests/compiler/test/d/d.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/test/d/d.rkt similarity index 100% rename from collects/tests/compiler/test/d/d.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/test/d/d.rkt diff --git a/collects/tests/compiler/zo-exs.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/zo-exs.rkt similarity index 100% rename from collects/tests/compiler/zo-exs.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/zo-exs.rkt diff --git a/collects/tests/compiler/zo-test-util.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-util.rkt similarity index 100% rename from collects/tests/compiler/zo-test-util.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-util.rkt diff --git a/collects/tests/compiler/zo-test-worker.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-worker.rkt similarity index 100% rename from collects/tests/compiler/zo-test-worker.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-worker.rkt diff --git a/collects/tests/compiler/zo-test.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt similarity index 100% rename from collects/tests/compiler/zo-test.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt diff --git a/collects/tests/compiler/zo.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/zo.rkt similarity index 100% rename from collects/tests/compiler/zo.rkt rename to pkgs/racket-pkgs/racket-test/tests/compiler/zo.rkt diff --git a/collects/tests/racket/benchmarks/shootout/nothing.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/shootout/nothing.rkt similarity index 100% rename from collects/tests/racket/benchmarks/shootout/nothing.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/shootout/nothing.rkt diff --git a/collects/tests/racket/ctool.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/ctool.rkt similarity index 100% rename from collects/tests/racket/ctool.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/ctool.rkt diff --git a/collects/tests/racket/embed-asl.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-asl.rkt similarity index 100% rename from collects/tests/racket/embed-asl.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-asl.rkt diff --git a/collects/tests/racket/embed-bsl.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-bsl.rkt similarity index 100% rename from collects/tests/racket/embed-bsl.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-bsl.rkt diff --git a/collects/tests/racket/embed-bsla.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-bsla.rkt similarity index 100% rename from collects/tests/racket/embed-bsla.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-bsla.rkt diff --git a/collects/tests/racket/embed-isl.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-isl.rkt similarity index 100% rename from collects/tests/racket/embed-isl.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-isl.rkt diff --git a/collects/tests/racket/embed-isll.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-isll.rkt similarity index 100% rename from collects/tests/racket/embed-isll.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-isll.rkt diff --git a/collects/tests/racket/embed-me1.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1.rkt similarity index 100% rename from collects/tests/racket/embed-me1.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me1.rkt diff --git a/collects/tests/racket/embed-me10.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me10.rkt similarity index 100% rename from collects/tests/racket/embed-me10.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me10.rkt diff --git a/collects/tests/racket/embed-me11-rd.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me11-rd.rkt similarity index 100% rename from collects/tests/racket/embed-me11-rd.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me11-rd.rkt diff --git a/collects/tests/racket/embed-me12-rd.ss b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me12-rd.ss similarity index 100% rename from collects/tests/racket/embed-me12-rd.ss rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me12-rd.ss diff --git a/collects/tests/racket/embed-me13.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me13.rkt similarity index 100% rename from collects/tests/racket/embed-me13.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me13.rkt diff --git a/collects/tests/racket/embed-me14.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me14.rkt similarity index 100% rename from collects/tests/racket/embed-me14.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me14.rkt diff --git a/collects/tests/racket/embed-me15-one.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me15-one.rkt similarity index 100% rename from collects/tests/racket/embed-me15-one.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me15-one.rkt diff --git a/collects/tests/racket/embed-me15.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me15.rkt similarity index 100% rename from collects/tests/racket/embed-me15.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me15.rkt diff --git a/collects/tests/racket/embed-me16.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me16.rkt similarity index 100% rename from collects/tests/racket/embed-me16.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me16.rkt diff --git a/collects/tests/racket/embed-me17.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me17.rkt similarity index 100% rename from collects/tests/racket/embed-me17.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me17.rkt diff --git a/collects/tests/racket/embed-me17a.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me17a.rkt similarity index 100% rename from collects/tests/racket/embed-me17a.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me17a.rkt diff --git a/collects/tests/racket/embed-me18a.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me18a.rkt similarity index 100% rename from collects/tests/racket/embed-me18a.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me18a.rkt diff --git a/collects/tests/racket/embed-me19.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me19.rkt similarity index 100% rename from collects/tests/racket/embed-me19.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me19.rkt diff --git a/collects/tests/racket/embed-me1b.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1b.rkt similarity index 100% rename from collects/tests/racket/embed-me1b.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me1b.rkt diff --git a/collects/tests/racket/embed-me1c.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1c.rkt similarity index 100% rename from collects/tests/racket/embed-me1c.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me1c.rkt diff --git a/collects/tests/racket/embed-me1d.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1d.rkt similarity index 100% rename from collects/tests/racket/embed-me1d.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me1d.rkt diff --git a/collects/tests/racket/embed-me1e.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1e.rkt similarity index 100% rename from collects/tests/racket/embed-me1e.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me1e.rkt diff --git a/collects/tests/racket/embed-me2.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me2.rkt similarity index 100% rename from collects/tests/racket/embed-me2.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me2.rkt diff --git a/collects/tests/racket/embed-me20.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me20.rkt similarity index 100% rename from collects/tests/racket/embed-me20.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me20.rkt diff --git a/collects/tests/racket/embed-me21.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me21.rkt similarity index 100% rename from collects/tests/racket/embed-me21.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me21.rkt diff --git a/collects/tests/racket/embed-me22.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me22.rkt similarity index 100% rename from collects/tests/racket/embed-me22.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me22.rkt diff --git a/collects/tests/racket/embed-me3.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me3.rkt similarity index 100% rename from collects/tests/racket/embed-me3.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me3.rkt diff --git a/collects/tests/racket/embed-me4.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me4.rktl similarity index 100% rename from collects/tests/racket/embed-me4.rktl rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me4.rktl diff --git a/collects/tests/racket/embed-me5.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me5.rkt similarity index 100% rename from collects/tests/racket/embed-me5.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me5.rkt diff --git a/collects/tests/racket/embed-me6.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me6.rkt similarity index 100% rename from collects/tests/racket/embed-me6.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me6.rkt diff --git a/collects/tests/racket/embed-me8.c b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me8.c similarity index 100% rename from collects/tests/racket/embed-me8.c rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me8.c diff --git a/collects/tests/racket/embed-me9.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me9.rkt similarity index 100% rename from collects/tests/racket/embed-me9.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-me9.rkt diff --git a/collects/tests/racket/embed-place.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-place.rkt similarity index 100% rename from collects/tests/racket/embed-place.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-place.rkt diff --git a/collects/tests/racket/embed-planet-1/alt.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/alt.rkt similarity index 100% rename from collects/tests/racket/embed-planet-1/alt.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/alt.rkt diff --git a/collects/tests/racket/embed-planet-1/dyn-sub.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/dyn-sub.rkt similarity index 100% rename from collects/tests/racket/embed-planet-1/dyn-sub.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/dyn-sub.rkt diff --git a/collects/tests/racket/embed-planet-1/has-sub.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/has-sub.rkt similarity index 100% rename from collects/tests/racket/embed-planet-1/has-sub.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/has-sub.rkt diff --git a/collects/tests/racket/embed-planet-1/main.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/main.rkt similarity index 100% rename from collects/tests/racket/embed-planet-1/main.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/main.rkt diff --git a/collects/tests/racket/embed-planet-1/other.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/other.rkt similarity index 100% rename from collects/tests/racket/embed-planet-1/other.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/other.rkt diff --git a/collects/tests/racket/embed-planet-2/main.ss b/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/main.ss similarity index 100% rename from collects/tests/racket/embed-planet-2/main.ss rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/main.ss diff --git a/collects/tests/racket/embed-planet-2/private/sub.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/private/sub.rkt similarity index 100% rename from collects/tests/racket/embed-planet-2/private/sub.rkt rename to pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/private/sub.rkt diff --git a/collects/tests/racket/embed.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl similarity index 100% rename from collects/tests/racket/embed.rktl rename to pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl diff --git a/collects/compiler/bundle-dist.rkt b/racket/lib/collects/compiler/bundle-dist.rkt similarity index 100% rename from collects/compiler/bundle-dist.rkt rename to racket/lib/collects/compiler/bundle-dist.rkt diff --git a/collects/compiler/commands/decompile.rkt b/racket/lib/collects/compiler/commands/decompile.rkt similarity index 100% rename from collects/compiler/commands/decompile.rkt rename to racket/lib/collects/compiler/commands/decompile.rkt diff --git a/collects/compiler/commands/exe-dir.rkt b/racket/lib/collects/compiler/commands/exe-dir.rkt similarity index 100% rename from collects/compiler/commands/exe-dir.rkt rename to racket/lib/collects/compiler/commands/exe-dir.rkt diff --git a/collects/compiler/commands/exe.rkt b/racket/lib/collects/compiler/commands/exe.rkt similarity index 100% rename from collects/compiler/commands/exe.rkt rename to racket/lib/collects/compiler/commands/exe.rkt diff --git a/collects/compiler/commands/expand.rkt b/racket/lib/collects/compiler/commands/expand.rkt similarity index 100% rename from collects/compiler/commands/expand.rkt rename to racket/lib/collects/compiler/commands/expand.rkt diff --git a/collects/compiler/commands/info.rkt b/racket/lib/collects/compiler/commands/info.rkt similarity index 100% rename from collects/compiler/commands/info.rkt rename to racket/lib/collects/compiler/commands/info.rkt diff --git a/collects/compiler/commands/make.rkt b/racket/lib/collects/compiler/commands/make.rkt similarity index 100% rename from collects/compiler/commands/make.rkt rename to racket/lib/collects/compiler/commands/make.rkt diff --git a/collects/compiler/commands/pack.rkt b/racket/lib/collects/compiler/commands/pack.rkt similarity index 100% rename from collects/compiler/commands/pack.rkt rename to racket/lib/collects/compiler/commands/pack.rkt diff --git a/collects/compiler/commands/test.rkt b/racket/lib/collects/compiler/commands/test.rkt similarity index 100% rename from collects/compiler/commands/test.rkt rename to racket/lib/collects/compiler/commands/test.rkt diff --git a/collects/compiler/commands/unpack.rkt b/racket/lib/collects/compiler/commands/unpack.rkt similarity index 100% rename from collects/compiler/commands/unpack.rkt rename to racket/lib/collects/compiler/commands/unpack.rkt diff --git a/collects/compiler/decompile.rkt b/racket/lib/collects/compiler/decompile.rkt similarity index 100% rename from collects/compiler/decompile.rkt rename to racket/lib/collects/compiler/decompile.rkt diff --git a/collects/compiler/demodularizer/alpha.rkt b/racket/lib/collects/compiler/demodularizer/alpha.rkt similarity index 100% rename from collects/compiler/demodularizer/alpha.rkt rename to racket/lib/collects/compiler/demodularizer/alpha.rkt diff --git a/collects/compiler/demodularizer/batch.rkt b/racket/lib/collects/compiler/demodularizer/batch.rkt similarity index 100% rename from collects/compiler/demodularizer/batch.rkt rename to racket/lib/collects/compiler/demodularizer/batch.rkt diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/racket/lib/collects/compiler/demodularizer/gc-toplevels.rkt similarity index 100% rename from collects/compiler/demodularizer/gc-toplevels.rkt rename to racket/lib/collects/compiler/demodularizer/gc-toplevels.rkt diff --git a/collects/compiler/demodularizer/main.rkt b/racket/lib/collects/compiler/demodularizer/main.rkt similarity index 100% rename from collects/compiler/demodularizer/main.rkt rename to racket/lib/collects/compiler/demodularizer/main.rkt diff --git a/collects/compiler/demodularizer/merge.rkt b/racket/lib/collects/compiler/demodularizer/merge.rkt similarity index 100% rename from collects/compiler/demodularizer/merge.rkt rename to racket/lib/collects/compiler/demodularizer/merge.rkt diff --git a/collects/compiler/demodularizer/module.rkt b/racket/lib/collects/compiler/demodularizer/module.rkt similarity index 100% rename from collects/compiler/demodularizer/module.rkt rename to racket/lib/collects/compiler/demodularizer/module.rkt diff --git a/collects/compiler/demodularizer/mpi.rkt b/racket/lib/collects/compiler/demodularizer/mpi.rkt similarity index 100% rename from collects/compiler/demodularizer/mpi.rkt rename to racket/lib/collects/compiler/demodularizer/mpi.rkt diff --git a/collects/compiler/demodularizer/nodep.rkt b/racket/lib/collects/compiler/demodularizer/nodep.rkt similarity index 100% rename from collects/compiler/demodularizer/nodep.rkt rename to racket/lib/collects/compiler/demodularizer/nodep.rkt diff --git a/collects/compiler/demodularizer/replace-modidx.rkt b/racket/lib/collects/compiler/demodularizer/replace-modidx.rkt similarity index 100% rename from collects/compiler/demodularizer/replace-modidx.rkt rename to racket/lib/collects/compiler/demodularizer/replace-modidx.rkt diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/racket/lib/collects/compiler/demodularizer/update-toplevels.rkt similarity index 100% rename from collects/compiler/demodularizer/update-toplevels.rkt rename to racket/lib/collects/compiler/demodularizer/update-toplevels.rkt diff --git a/collects/compiler/demodularizer/util.rkt b/racket/lib/collects/compiler/demodularizer/util.rkt similarity index 100% rename from collects/compiler/demodularizer/util.rkt rename to racket/lib/collects/compiler/demodularizer/util.rkt diff --git a/collects/compiler/embed-sig.rkt b/racket/lib/collects/compiler/embed-sig.rkt similarity index 100% rename from collects/compiler/embed-sig.rkt rename to racket/lib/collects/compiler/embed-sig.rkt diff --git a/collects/compiler/sig.rkt b/racket/lib/collects/compiler/sig.rkt similarity index 100% rename from collects/compiler/sig.rkt rename to racket/lib/collects/compiler/sig.rkt diff --git a/collects/compiler/zo-marshal.rkt b/racket/lib/collects/compiler/zo-marshal.rkt similarity index 100% rename from collects/compiler/zo-marshal.rkt rename to racket/lib/collects/compiler/zo-marshal.rkt diff --git a/collects/compiler/zo-parse.rkt b/racket/lib/collects/compiler/zo-parse.rkt similarity index 100% rename from collects/compiler/zo-parse.rkt rename to racket/lib/collects/compiler/zo-parse.rkt diff --git a/collects/compiler/zo-structs.rkt b/racket/lib/collects/compiler/zo-structs.rkt similarity index 100% rename from collects/compiler/zo-structs.rkt rename to racket/lib/collects/compiler/zo-structs.rkt diff --git a/collects/launcher/launcher-sig.rkt b/racket/lib/collects/launcher/launcher-sig.rkt similarity index 100% rename from collects/launcher/launcher-sig.rkt rename to racket/lib/collects/launcher/launcher-sig.rkt diff --git a/collects/setup/option-sig.rkt b/racket/lib/collects/setup/option-sig.rkt similarity index 100% rename from collects/setup/option-sig.rkt rename to racket/lib/collects/setup/option-sig.rkt From f2627708e95a49e0706b61ba7271b4b1216db831 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 25 Jun 2013 22:17:38 +0200 Subject: [PATCH 314/466] a step toward single-collection packages as default A package's "info.rkt" file should define `collection' as a string to name a single-collection package's collection, or as the symbol 'multi to declare the package as multi-collection. If `collection' is 'same-as-pkg, then the package name is used as the collection name. The default for `collection' is 'multi for now, but the intent is to change the default to 'same-as-pkg after a conversion period. Also, support for a `single-collection' definition remains in place, but it wil be removed. original commit: c738a6aa3eee89a82d577dd35c70eca8ed32f5b4 --- pkgs/racket-pkgs/at-exp-lib/info.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/pkgs/racket-pkgs/at-exp-lib/info.rkt b/pkgs/racket-pkgs/at-exp-lib/info.rkt index c14a2ca411..b85118802f 100644 --- a/pkgs/racket-pkgs/at-exp-lib/info.rkt +++ b/pkgs/racket-pkgs/at-exp-lib/info.rkt @@ -1 +1,3 @@ #lang setup/infotab + +(define collection 'multi) From 986ec9297bd6cb7ff73e85321862cea5662714a0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 26 Jun 2013 11:52:28 -0400 Subject: [PATCH 315/466] Move much of `mzlib` to `compatibility-lib` package. original commit: 7917f32d0c79ec71095e2e42bb41e981708129cc --- racket/lib/collects/compiler/bundle-dist.rkt | 13 +++++++------ racket/lib/collects/compiler/embed-sig.rkt | 2 +- racket/lib/collects/compiler/sig.rkt | 2 +- racket/lib/collects/compiler/zo-structs.rkt | 3 +-- racket/lib/collects/setup/option-sig.rkt | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/racket/lib/collects/compiler/bundle-dist.rkt b/racket/lib/collects/compiler/bundle-dist.rkt index 02a671be4f..e7b596d260 100644 --- a/racket/lib/collects/compiler/bundle-dist.rkt +++ b/racket/lib/collects/compiler/bundle-dist.rkt @@ -1,10 +1,11 @@ (module bundle-dist mzscheme - (require mzlib/etc - mzlib/file - mzlib/process - mzlib/zip - mzlib/tar) + (require racket/file + (only racket/base lambda) + racket/path + racket/system + file/zip + file/tar) (provide bundle-put-file-extension+style+filters bundle-directory) @@ -61,7 +62,7 @@ (lambda () (delete-directory/files temp-dir)))))) (define bundle-directory - (opt-lambda (target dir [for-exe? #f]) + (lambda (target dir [for-exe? #f]) (let ([target (add-suffix target (bundle-file-suffix))]) (case (system-type) [(macosx) diff --git a/racket/lib/collects/compiler/embed-sig.rkt b/racket/lib/collects/compiler/embed-sig.rkt index a5e949c9a8..e7cac31ad2 100644 --- a/racket/lib/collects/compiler/embed-sig.rkt +++ b/racket/lib/collects/compiler/embed-sig.rkt @@ -1,6 +1,6 @@ (module embed-sig mzscheme - (require mzlib/unit) + (require racket/unit) (provide compiler:embed^) (define-signature compiler:embed^ diff --git a/racket/lib/collects/compiler/sig.rkt b/racket/lib/collects/compiler/sig.rkt index 63267b13c5..860a07eb70 100644 --- a/racket/lib/collects/compiler/sig.rkt +++ b/racket/lib/collects/compiler/sig.rkt @@ -1,7 +1,7 @@ #lang mzscheme -(require mzlib/unit) +(require racket/unit) (provide compiler:option^ compiler^) diff --git a/racket/lib/collects/compiler/zo-structs.rkt b/racket/lib/collects/compiler/zo-structs.rkt index 1221cdad02..52be542051 100644 --- a/racket/lib/collects/compiler/zo-structs.rkt +++ b/racket/lib/collects/compiler/zo-structs.rkt @@ -1,6 +1,5 @@ #lang scheme/base -(require mzlib/etc - scheme/match +(require scheme/match scheme/contract scheme/list racket/set) diff --git a/racket/lib/collects/setup/option-sig.rkt b/racket/lib/collects/setup/option-sig.rkt index aa4f6abb4c..8dad393247 100644 --- a/racket/lib/collects/setup/option-sig.rkt +++ b/racket/lib/collects/setup/option-sig.rkt @@ -1,6 +1,6 @@ (module option-sig mzscheme - (require mzlib/unit) + (require racket/unit) (provide setup-option^) From 04efdd405d4fe898525b89f65531d3df6181f6bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 28 Jun 2013 21:04:59 -0600 Subject: [PATCH 316/466] raco setup: add package-dependency checking The new `--no-pkg-deps' or `-K' flag skips the check. If a module in package X refers to a module in package Y, check that package X declares a dependency on Y. Note that package X must specifically depend on Y --- not another package that at the moment happens to declare a dependency on Y. A new "base" package represents the content of the core (so that, if the core shrinks, a new "base2" can represent the smaller core). Most every package now needs a dependency on "base". Sometimes, it makes sense for X to access Y when X declares a dependency on Z, because Z promises to always depend on Y. For example, the "gui" package is defined to combne "gui-lib" and "gui-doc", so it's appropriate to use the modules of "gui-lib" when depending on "gui". A package's "info.rkt" can therefore define `implies' as a subset of the dependencies listed in `deps', which means that depending on the package implies a dependency on the listed packages. (It's even possible for packages to mutually imply each other, which is why the dependency checking code ends up with a union-find.) Dependency checking distinguishes between run-time dependencies and build-time dependencies: anything listed in a ".dep" file is a build dependency, at least. To imply a run-time dependency, a reference must appear in a bytecode file's imports, and not in a subdirectory or submodule that would be pruned for a binary package. The `--fix-pkg-deps' flag attempts to automatically fix package dependency declarations (i.e., modify a package's "info.rkt" file) based on inferred dependencies. original commit: 04d5d9bd55d8258221e6e4cfba0c7991498202ed --- racket/lib/collects/setup/option-sig.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/racket/lib/collects/setup/option-sig.rkt b/racket/lib/collects/setup/option-sig.rkt index 8dad393247..d9f5b43bf5 100644 --- a/racket/lib/collects/setup/option-sig.rkt +++ b/racket/lib/collects/setup/option-sig.rkt @@ -22,6 +22,8 @@ avoid-main-installation make-tidy make-doc-index + check-dependencies + fix-dependencies call-install call-post-install pause-on-errors From 3ef406b5c667b3755da899e389c68bf68b16bfc4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 29 Jun 2013 05:42:38 -0600 Subject: [PATCH 317/466] auto-fix dependencies in "pkgs" Left one dependency broken: "drracket" currently depends on "htdp" for a test. That needs to be fixed by removing the dependency (moving the test to "htdp?), instead of changing the declared dependencies. original commit: 51290fd2a95def6bb3b6d3d735cb62444e157553 --- pkgs/racket-pkgs/at-exp-lib/info.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/pkgs/racket-pkgs/at-exp-lib/info.rkt b/pkgs/racket-pkgs/at-exp-lib/info.rkt index b85118802f..e43df74125 100644 --- a/pkgs/racket-pkgs/at-exp-lib/info.rkt +++ b/pkgs/racket-pkgs/at-exp-lib/info.rkt @@ -1,3 +1,4 @@ #lang setup/infotab (define collection 'multi) +(define deps '("base")) From 1c93e0f023d08406f0f2480f2a1ba76bd6d763e2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 30 Jun 2013 10:04:34 -0400 Subject: [PATCH 318/466] Remove most uses of `mzscheme` in the core. Remaining are: - parts of unit200 that Matthew plans to remove. - the `mzscheme` implementation itself. The implementation of `mzscheme` has been moved to the `mzscheme` collection (from the `racket` and `scheme` collections). The `scheme/mzscheme` language, which was undocumented, has been removed. This is slightly backwards-incompatible, because the `xform` handling of precompiled headers now evaluates code in a `racket/base`-like namespace, instead of in a `mzscheme`-like namespace. original commit: d54c1e4e4942c26dcbaaebcc43d5c92d507a8112 --- racket/lib/collects/compiler/bundle-dist.rkt | 8 ++++---- racket/lib/collects/compiler/embed-sig.rkt | 2 +- racket/lib/collects/compiler/sig.rkt | 3 +-- racket/lib/collects/setup/option-sig.rkt | 3 +-- 4 files changed, 7 insertions(+), 9 deletions(-) diff --git a/racket/lib/collects/compiler/bundle-dist.rkt b/racket/lib/collects/compiler/bundle-dist.rkt index e7b596d260..af419cf515 100644 --- a/racket/lib/collects/compiler/bundle-dist.rkt +++ b/racket/lib/collects/compiler/bundle-dist.rkt @@ -1,7 +1,7 @@ -(module bundle-dist mzscheme +(module bundle-dist racket/base (require racket/file - (only racket/base lambda) + (only-in racket/base lambda) racket/path racket/system file/zip @@ -80,8 +80,8 @@ "-mode" "555" "-volname" (path->string (path-replace-suffix (file-name-from-path target) #"")) - "-srcfolder" (path->string (expand-path (path->complete-path dir))) - (path->string (expand-path (path->complete-path target))))]) + "-srcfolder" (path->string (cleanse-path (path->complete-path dir))) + (path->string (cleanse-path (path->complete-path target))))]) ((list-ref p 4) 'wait) (unless (eq? ((list-ref p 4) 'status) 'done-ok) (error 'bundle-directory diff --git a/racket/lib/collects/compiler/embed-sig.rkt b/racket/lib/collects/compiler/embed-sig.rkt index e7cac31ad2..aeded68b62 100644 --- a/racket/lib/collects/compiler/embed-sig.rkt +++ b/racket/lib/collects/compiler/embed-sig.rkt @@ -1,5 +1,5 @@ -(module embed-sig mzscheme +(module embed-sig racket/base (require racket/unit) (provide compiler:embed^) diff --git a/racket/lib/collects/compiler/sig.rkt b/racket/lib/collects/compiler/sig.rkt index 860a07eb70..87f1af4dda 100644 --- a/racket/lib/collects/compiler/sig.rkt +++ b/racket/lib/collects/compiler/sig.rkt @@ -1,5 +1,4 @@ - -#lang mzscheme +#lang racket/base (require racket/unit) diff --git a/racket/lib/collects/setup/option-sig.rkt b/racket/lib/collects/setup/option-sig.rkt index d9f5b43bf5..2900009479 100644 --- a/racket/lib/collects/setup/option-sig.rkt +++ b/racket/lib/collects/setup/option-sig.rkt @@ -1,5 +1,4 @@ - -(module option-sig mzscheme +(module option-sig scheme/base (require racket/unit) (provide setup-option^) From 4ebcdce773f00b87de836404bcbd42a28de1ab4d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 30 Jun 2013 19:38:33 -0400 Subject: [PATCH 319/466] Move most of the `compiler` collection to `compiler-lib`. original commit: 3ad009070e063614f22a32fbbffa950a8d84e599 --- .../collects => pkgs/compiler-lib}/compiler/bundle-dist.rkt | 0 .../compiler-lib}/compiler/commands/decompile.rkt | 0 .../compiler-lib}/compiler/commands/exe-dir.rkt | 0 .../collects => pkgs/compiler-lib}/compiler/commands/exe.rkt | 0 .../compiler-lib}/compiler/commands/expand.rkt | 0 .../collects => pkgs/compiler-lib}/compiler/commands/info.rkt | 0 .../collects => pkgs/compiler-lib}/compiler/commands/make.rkt | 0 .../collects => pkgs/compiler-lib}/compiler/commands/pack.rkt | 0 .../collects => pkgs/compiler-lib}/compiler/commands/test.rkt | 0 .../compiler-lib}/compiler/commands/unpack.rkt | 0 .../lib/collects => pkgs/compiler-lib}/compiler/decompile.rkt | 0 .../compiler-lib}/compiler/demodularizer/alpha.rkt | 0 .../compiler-lib}/compiler/demodularizer/batch.rkt | 0 .../compiler-lib}/compiler/demodularizer/gc-toplevels.rkt | 0 .../compiler-lib}/compiler/demodularizer/main.rkt | 0 .../compiler-lib}/compiler/demodularizer/merge.rkt | 0 .../compiler-lib}/compiler/demodularizer/module.rkt | 0 .../compiler-lib}/compiler/demodularizer/mpi.rkt | 0 .../compiler-lib}/compiler/demodularizer/nodep.rkt | 0 .../compiler-lib}/compiler/demodularizer/replace-modidx.rkt | 0 .../compiler-lib}/compiler/demodularizer/update-toplevels.rkt | 0 .../compiler-lib}/compiler/demodularizer/util.rkt | 0 .../lib/collects => pkgs/compiler-lib}/compiler/zo-marshal.rkt | 0 .../lib/collects => pkgs/compiler-lib}/compiler/zo-parse.rkt | 0 .../lib/collects => pkgs/compiler-lib}/compiler/zo-structs.rkt | 0 pkgs/compiler-lib/info.rkt | 3 +++ 26 files changed, 3 insertions(+) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/bundle-dist.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/decompile.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/exe-dir.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/exe.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/expand.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/info.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/make.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/pack.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/test.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/commands/unpack.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/decompile.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/alpha.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/batch.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/gc-toplevels.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/main.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/merge.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/module.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/mpi.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/nodep.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/replace-modidx.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/update-toplevels.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/demodularizer/util.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/zo-marshal.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/zo-parse.rkt (100%) rename {racket/lib/collects => pkgs/compiler-lib}/compiler/zo-structs.rkt (100%) create mode 100644 pkgs/compiler-lib/info.rkt diff --git a/racket/lib/collects/compiler/bundle-dist.rkt b/pkgs/compiler-lib/compiler/bundle-dist.rkt similarity index 100% rename from racket/lib/collects/compiler/bundle-dist.rkt rename to pkgs/compiler-lib/compiler/bundle-dist.rkt diff --git a/racket/lib/collects/compiler/commands/decompile.rkt b/pkgs/compiler-lib/compiler/commands/decompile.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/decompile.rkt rename to pkgs/compiler-lib/compiler/commands/decompile.rkt diff --git a/racket/lib/collects/compiler/commands/exe-dir.rkt b/pkgs/compiler-lib/compiler/commands/exe-dir.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/exe-dir.rkt rename to pkgs/compiler-lib/compiler/commands/exe-dir.rkt diff --git a/racket/lib/collects/compiler/commands/exe.rkt b/pkgs/compiler-lib/compiler/commands/exe.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/exe.rkt rename to pkgs/compiler-lib/compiler/commands/exe.rkt diff --git a/racket/lib/collects/compiler/commands/expand.rkt b/pkgs/compiler-lib/compiler/commands/expand.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/expand.rkt rename to pkgs/compiler-lib/compiler/commands/expand.rkt diff --git a/racket/lib/collects/compiler/commands/info.rkt b/pkgs/compiler-lib/compiler/commands/info.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/info.rkt rename to pkgs/compiler-lib/compiler/commands/info.rkt diff --git a/racket/lib/collects/compiler/commands/make.rkt b/pkgs/compiler-lib/compiler/commands/make.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/make.rkt rename to pkgs/compiler-lib/compiler/commands/make.rkt diff --git a/racket/lib/collects/compiler/commands/pack.rkt b/pkgs/compiler-lib/compiler/commands/pack.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/pack.rkt rename to pkgs/compiler-lib/compiler/commands/pack.rkt diff --git a/racket/lib/collects/compiler/commands/test.rkt b/pkgs/compiler-lib/compiler/commands/test.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/test.rkt rename to pkgs/compiler-lib/compiler/commands/test.rkt diff --git a/racket/lib/collects/compiler/commands/unpack.rkt b/pkgs/compiler-lib/compiler/commands/unpack.rkt similarity index 100% rename from racket/lib/collects/compiler/commands/unpack.rkt rename to pkgs/compiler-lib/compiler/commands/unpack.rkt diff --git a/racket/lib/collects/compiler/decompile.rkt b/pkgs/compiler-lib/compiler/decompile.rkt similarity index 100% rename from racket/lib/collects/compiler/decompile.rkt rename to pkgs/compiler-lib/compiler/decompile.rkt diff --git a/racket/lib/collects/compiler/demodularizer/alpha.rkt b/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/alpha.rkt rename to pkgs/compiler-lib/compiler/demodularizer/alpha.rkt diff --git a/racket/lib/collects/compiler/demodularizer/batch.rkt b/pkgs/compiler-lib/compiler/demodularizer/batch.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/batch.rkt rename to pkgs/compiler-lib/compiler/demodularizer/batch.rkt diff --git a/racket/lib/collects/compiler/demodularizer/gc-toplevels.rkt b/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/gc-toplevels.rkt rename to pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt diff --git a/racket/lib/collects/compiler/demodularizer/main.rkt b/pkgs/compiler-lib/compiler/demodularizer/main.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/main.rkt rename to pkgs/compiler-lib/compiler/demodularizer/main.rkt diff --git a/racket/lib/collects/compiler/demodularizer/merge.rkt b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/merge.rkt rename to pkgs/compiler-lib/compiler/demodularizer/merge.rkt diff --git a/racket/lib/collects/compiler/demodularizer/module.rkt b/pkgs/compiler-lib/compiler/demodularizer/module.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/module.rkt rename to pkgs/compiler-lib/compiler/demodularizer/module.rkt diff --git a/racket/lib/collects/compiler/demodularizer/mpi.rkt b/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/mpi.rkt rename to pkgs/compiler-lib/compiler/demodularizer/mpi.rkt diff --git a/racket/lib/collects/compiler/demodularizer/nodep.rkt b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/nodep.rkt rename to pkgs/compiler-lib/compiler/demodularizer/nodep.rkt diff --git a/racket/lib/collects/compiler/demodularizer/replace-modidx.rkt b/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/replace-modidx.rkt rename to pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt diff --git a/racket/lib/collects/compiler/demodularizer/update-toplevels.rkt b/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/update-toplevels.rkt rename to pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt diff --git a/racket/lib/collects/compiler/demodularizer/util.rkt b/pkgs/compiler-lib/compiler/demodularizer/util.rkt similarity index 100% rename from racket/lib/collects/compiler/demodularizer/util.rkt rename to pkgs/compiler-lib/compiler/demodularizer/util.rkt diff --git a/racket/lib/collects/compiler/zo-marshal.rkt b/pkgs/compiler-lib/compiler/zo-marshal.rkt similarity index 100% rename from racket/lib/collects/compiler/zo-marshal.rkt rename to pkgs/compiler-lib/compiler/zo-marshal.rkt diff --git a/racket/lib/collects/compiler/zo-parse.rkt b/pkgs/compiler-lib/compiler/zo-parse.rkt similarity index 100% rename from racket/lib/collects/compiler/zo-parse.rkt rename to pkgs/compiler-lib/compiler/zo-parse.rkt diff --git a/racket/lib/collects/compiler/zo-structs.rkt b/pkgs/compiler-lib/compiler/zo-structs.rkt similarity index 100% rename from racket/lib/collects/compiler/zo-structs.rkt rename to pkgs/compiler-lib/compiler/zo-structs.rkt diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-lib/info.rkt new file mode 100644 index 0000000000..a4c4a02943 --- /dev/null +++ b/pkgs/compiler-lib/info.rkt @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define deps '("base")) From b63d902657e272ce8061eeecd644a829ff550fee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 3 Jul 2013 17:03:25 -0600 Subject: [PATCH 320/466] make packages single-collection by default The `single-collection' "info.rkt" definition is no longer supported. original commit: aabbfdc3d55586239932287eb7d9f0a2395e6919 --- pkgs/compiler-lib/info.rkt | 2 ++ pkgs/racket-pkgs/at-exp-lib/info.rkt | 4 ---- 2 files changed, 2 insertions(+), 4 deletions(-) delete mode 100644 pkgs/racket-pkgs/at-exp-lib/info.rkt diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-lib/info.rkt index a4c4a02943..96ecf48be3 100644 --- a/pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-lib/info.rkt @@ -1,3 +1,5 @@ #lang setup/infotab +(define collection 'multi) + (define deps '("base")) diff --git a/pkgs/racket-pkgs/at-exp-lib/info.rkt b/pkgs/racket-pkgs/at-exp-lib/info.rkt deleted file mode 100644 index e43df74125..0000000000 --- a/pkgs/racket-pkgs/at-exp-lib/info.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang setup/infotab - -(define collection 'multi) -(define deps '("base")) From 5a758b6ecc587583668736d2a39fcf722988a15a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 4 Jul 2013 15:45:47 -0400 Subject: [PATCH 321/466] Use `#lang info` instead of `#lang setup/infotab`. original commit: 5a7ca7ebb56b2215f2d395ed052c03ea740817ea --- pkgs/compiler-lib/compiler/commands/info.rkt | 2 +- pkgs/compiler-lib/info.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/pkgs/compiler-lib/compiler/commands/info.rkt b/pkgs/compiler-lib/compiler/commands/info.rkt index 6faf16eb19..a3f02f0725 100644 --- a/pkgs/compiler-lib/compiler/commands/info.rkt +++ b/pkgs/compiler-lib/compiler/commands/info.rkt @@ -1,4 +1,4 @@ -#lang setup/infotab +#lang info (define raco-commands '(("make" compiler/commands/make "compile source to bytecode" 100) diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-lib/info.rkt index 96ecf48be3..95c32105ee 100644 --- a/pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-lib/info.rkt @@ -1,4 +1,4 @@ -#lang setup/infotab +#lang info (define collection 'multi) From 47148430d2c8ed1547bc0d2454de6612ccf02041 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Jul 2013 15:56:24 -0600 Subject: [PATCH 322/466] enable compilation of tests formerly in "racket-test"; reorganize A package like "gui" does not depend on a package like "gui-test", which means that you have to specifically ask for a test package if you want the tests. A new "main-distribution-test" package aggregates the tests for packages that are in "main-distribution". The "plt-services" package, meanwhile, depends on the "main-distribution-test" package, which means that all tests are compiled by default for an in-place build. original commit: d50d0f8bcab260f404049029b77407e0222f588a --- pkgs/racket-pkgs/racket-test/tests/racket/info.rkt | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 pkgs/racket-pkgs/racket-test/tests/racket/info.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/info.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/info.rkt new file mode 100644 index 0000000000..7882f9f179 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/info.rkt @@ -0,0 +1,14 @@ +#lang info + +(define compile-omit-paths '("embed-me9.rkt" + "embed-planet-1" + + ;; Could be compiled, but we skep them to avoid + ;; dependencies. This needs to be cleaned up. + "embed-me5.rkt" + "embed-me19.rkt" + "embed-bsl.rkt" + "embed-bsla.rkt" + "embed-isl.rkt" + "embed-isll.rkt" + "embed-asl.rkt")) From 7ef3b0c72a0e2d5881689d08d7f4f97a9f4e32a3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Jul 2013 04:49:29 -0600 Subject: [PATCH 323/466] add "share", move "collects" back out of "lib", move "pkgs" The "share" directory holds platform-independent files, while "lib" holds platform-specific files. In principle, the "collects" directory belongs in "share", as does "doc". Those directories are put into "share" by a Unix-style install, but left at top level for an in-place install. Packages in installation scope are put in "share" instead of "lib", and the top-level Makefile puts development links in "share/devel-pkgs". The `configure' script now supports `--docdir' and `--collectsdir'. Changed the version to 5.90.0.1. original commit: 67a9889ef750ce88139e17da6d8f807adcccc68e --- racket/{lib => }/collects/compiler/embed-sig.rkt | 0 racket/{lib => }/collects/compiler/sig.rkt | 0 racket/{lib => }/collects/launcher/launcher-sig.rkt | 0 racket/{lib => }/collects/setup/option-sig.rkt | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename racket/{lib => }/collects/compiler/embed-sig.rkt (100%) rename racket/{lib => }/collects/compiler/sig.rkt (100%) rename racket/{lib => }/collects/launcher/launcher-sig.rkt (100%) rename racket/{lib => }/collects/setup/option-sig.rkt (100%) diff --git a/racket/lib/collects/compiler/embed-sig.rkt b/racket/collects/compiler/embed-sig.rkt similarity index 100% rename from racket/lib/collects/compiler/embed-sig.rkt rename to racket/collects/compiler/embed-sig.rkt diff --git a/racket/lib/collects/compiler/sig.rkt b/racket/collects/compiler/sig.rkt similarity index 100% rename from racket/lib/collects/compiler/sig.rkt rename to racket/collects/compiler/sig.rkt diff --git a/racket/lib/collects/launcher/launcher-sig.rkt b/racket/collects/launcher/launcher-sig.rkt similarity index 100% rename from racket/lib/collects/launcher/launcher-sig.rkt rename to racket/collects/launcher/launcher-sig.rkt diff --git a/racket/lib/collects/setup/option-sig.rkt b/racket/collects/setup/option-sig.rkt similarity index 100% rename from racket/lib/collects/setup/option-sig.rkt rename to racket/collects/setup/option-sig.rkt From 05a7459d8e97c09f7a25891fb9378ef95af02e2d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Jul 2013 19:55:10 -0600 Subject: [PATCH 324/466] fix some tests original commit: 1708fb43b476bf7a13f1c2cef3a32f555769cf55 --- pkgs/compiler-lib/compiler/commands/pack.rkt | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/pkgs/compiler-lib/compiler/commands/pack.rkt b/pkgs/compiler-lib/compiler/commands/pack.rkt index db68d62889..eba5bf0865 100644 --- a/pkgs/compiler-lib/compiler/commands/pack.rkt +++ b/pkgs/compiler-lib/compiler/commands/pack.rkt @@ -71,10 +71,7 @@ #f '("collects" "doc" "include" "lib")) #:requires - ;; Get current version of mzscheme for require: - (let* ([i (get-info '("mzscheme"))] - [v (and i (i 'version (lambda () #f)))]) - (list (list '("mzscheme") v)))) + null) (when (verbose) (printf " [output to \"~a\"]\n" plt-output))) ;; Collection From b7f32c3cf315553539f9f6e9b0b3a8b034110618 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Jul 2013 17:50:52 -0600 Subject: [PATCH 325/466] add `pkg-desc' and `pkg-authors' to each package This information will be used to construct a catalog from the package directories. original commit: 057bfc2ea1a24e85ece2d5f85da30076643ea598 --- pkgs/compiler-lib/info.rkt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-lib/info.rkt index 95c32105ee..f650155470 100644 --- a/pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-lib/info.rkt @@ -3,3 +3,7 @@ (define collection 'multi) (define deps '("base")) + +(define pkg-desc "Racket compilation tools, such as `raco exe'") + +(define pkg-authors '(mflatt)) From 3a67e505bac77f39b1ae8e44972bc9cd14cfc55a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Aug 2013 12:08:26 -0600 Subject: [PATCH 326/466] fix some tests that need to find `racket' original commit: 4492cf25553c88be617deff9991392f00963fba3 --- .../tests/compiler/demodularizer/demod-test.rkt | 9 +++++---- pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt | 3 ++- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt index 5d88fbc82a..a10efce85e 100644 --- a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt @@ -1,6 +1,7 @@ #lang racket (require tests/eli-tester - racket/runtime-path) + racket/runtime-path + compiler/find-exe) (define (capture-output command . args) (define o (open-output-string)) @@ -14,7 +15,7 @@ (define (test-on-program filename) ; run modular program, capture output (define-values (modular-output modular-error) - (capture-output (find-executable-path "racket") filename)) + (capture-output (find-exe) filename)) (define demod-filename (let-values ([(base filename dir?) (split-path filename)]) @@ -25,11 +26,11 @@ ; demodularize (parameterize ([current-input-port (open-input-string "")]) - (system* (find-executable-path "raco") "demod" "-o" demod-filename filename)) + (system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename)) ; run whole program (define-values (whole-output whole-error) - (capture-output (find-executable-path "racket") demod-filename)) + (capture-output (find-exe) demod-filename)) ; compare output (test diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt index 5c7694085f..20158c5404 100755 --- a/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt @@ -7,6 +7,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (require setup/dirs racket/runtime-path racket/future + compiler/find-exe "zo-test-util.rkt") (define ((make-recorder! ht) file phase) @@ -63,7 +64,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (! p-str)])) (define-runtime-path zo-test-worker-path "zo-test-worker.rkt") -(define racket-path (path->string (find-executable-path "racket"))) +(define racket-path (path->string (find-exe))) (define p (command-line #:program "zo-test" From 3e1e9a635723895c59c3d3626af706c09905f3cd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Aug 2013 08:29:58 -0700 Subject: [PATCH 327/466] fix bytecode-format bug The range of values used to represent "improper lists" of length 36 to 65 overlapped with the range of values used to represent other things. This bug is the new chapion of the "how did we not hit that earlier?" category. The bug was introduced around v300, at the latest. original commit: b8db5aacb3ddeab0f75b35e32b69cd32ddb8992f --- pkgs/compiler-lib/compiler/zo-parse.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/compiler-lib/compiler/zo-parse.rkt b/pkgs/compiler-lib/compiler/zo-parse.rkt index 0d21c1fd06..5d3f8dce98 100644 --- a/pkgs/compiler-lib/compiler/zo-parse.rkt +++ b/pkgs/compiler-lib/compiler/zo-parse.rkt @@ -449,7 +449,7 @@ (set-cport-pos! cp (add1 (cport-pos cp))) r) -(define small-list-max 65) +(define small-list-max 50) (define raw-cpt-table ;; The "schcpt.h" mapping, earlier entries override later ones `([0 escape] From 377b06a3520c5b9a926fb224f146d5007d726c7e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Aug 2013 08:41:43 -0700 Subject: [PATCH 328/466] adjust `compiler/zo-marshal' for bytecode-file change Forgot to fix as part of b8db5aacb3. original commit: 3b76628eb14064abe75068a535d657b6ca19a869 --- pkgs/compiler-lib/compiler/zo-marshal.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/compiler-lib/compiler/zo-marshal.rkt b/pkgs/compiler-lib/compiler/zo-marshal.rkt index 8b17d1178c..38371c54a1 100644 --- a/pkgs/compiler-lib/compiler/zo-marshal.rkt +++ b/pkgs/compiler-lib/compiler/zo-marshal.rkt @@ -344,7 +344,7 @@ (define CPT_SMALL_MARSHALLED_START 80) (define CPT_SMALL_MARSHALLED_END 92) -(define CPT_SMALL_LIST_MAX 65) +(define CPT_SMALL_LIST_MAX 50) (define CPT_SMALL_PROPER_LIST_START 92) (define CPT_SMALL_PROPER_LIST_END (+ CPT_SMALL_PROPER_LIST_START CPT_SMALL_LIST_MAX)) From be324be798860c37771ca0ab3ddb0646e2be4fb8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 10 Aug 2013 08:46:43 -0600 Subject: [PATCH 329/466] Add ".desktop" file support A launcher can have a ".desktop" file (found like other files: as the same name as the main launcher file, but with a ".desktop" suffix), where the "Exec" and "Icon" fields are added automatically. A ".png" or ".ico" file can be supplied for the icon (where the ".ico" file is already used for Windows launchers). Closes PR 13953 Fix various problems with Unix-style install from an installer. Also, add an ugly icon for the Racket Package Manager, with the hope that it will provoke someone to create a nicer one. original commit: 58c0074a7181a1590dfa0a931ba63c29a4334726 --- racket/collects/launcher/launcher-sig.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/racket/collects/launcher/launcher-sig.rkt b/racket/collects/launcher/launcher-sig.rkt index 0000ef3ba4..9a2007b19f 100644 --- a/racket/collects/launcher/launcher-sig.rkt +++ b/racket/collects/launcher/launcher-sig.rkt @@ -52,3 +52,6 @@ available-mred-variants available-mzscheme-variants available-gracket-variants available-racket-variants + +installed-executable-path->desktop-path +installed-desktop-path->icon-path From ae6ce5f2faba91391c5b12074c4391b0a9696ea0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 Aug 2013 12:34:29 -0600 Subject: [PATCH 330/466] move "scheme" collection to a "scheme-lib" package Also, move remaining "srfi" libraries to "srfi-lite-lib". In principle, "base" should depend on "scheme-lib" and "srfi-lite-lib", and a new "base2" package would represent the new, smaller base. But I don't think the window has yet closed on determining the initial "base" package. The "srfi" libraries moved to "srfi-lite-lib", instead of "srfi-lib", to avoid creating many extra dependencies on "srfi-lib" and all of its dependencies. The SRFIs in "srfi-lite-lib" depend only on "base", and they are used relatively widely. original commit: d175c3949c602672d61734b3fc54750da1d57f89 --- racket/collects/launcher/launcher-sig.rkt | 2 +- racket/collects/setup/option-sig.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/racket/collects/launcher/launcher-sig.rkt b/racket/collects/launcher/launcher-sig.rkt index 9a2007b19f..5554889de1 100644 --- a/racket/collects/launcher/launcher-sig.rkt +++ b/racket/collects/launcher/launcher-sig.rkt @@ -1,4 +1,4 @@ -#lang scheme/signature +#lang racket/signature make-gracket-launcher make-racket-launcher diff --git a/racket/collects/setup/option-sig.rkt b/racket/collects/setup/option-sig.rkt index 2900009479..5308450163 100644 --- a/racket/collects/setup/option-sig.rkt +++ b/racket/collects/setup/option-sig.rkt @@ -1,4 +1,4 @@ -(module option-sig scheme/base +(module option-sig racket/base (require racket/unit) (provide setup-option^) From b51a206bf53c22165b5ec14964b116e3d31dd625 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 Aug 2013 15:18:23 -0600 Subject: [PATCH 331/466] auto-fix dependencies for "scheme-lib" and "srfi-lite-lib" original commit: c709af5bf4d3af8f8c7a5918cf0b521ac1846f78 --- pkgs/compiler-lib/info.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-lib/info.rkt index f650155470..21e9cc99f3 100644 --- a/pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-lib/info.rkt @@ -2,7 +2,8 @@ (define collection 'multi) -(define deps '("base")) +(define deps '("scheme-lib" + "base")) (define pkg-desc "Racket compilation tools, such as `raco exe'") From 0203850c3c8e444f6cb5948c7e813200d54532f0 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 28 Aug 2013 00:10:18 -0400 Subject: [PATCH 332/466] Changed set? to generic-set?. original commit: 6665f42e336a96835d95e420d48854dcd1c85b5d --- pkgs/compiler-lib/compiler/demodularizer/nodep.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt index 16d705cfca..50ca687268 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt @@ -210,6 +210,6 @@ ([modidx module-path-index?] [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] [get-modvar-rewrite/c contract?] - [current-excluded-modules (parameter/c set?)] + [current-excluded-modules (parameter/c generic-set?)] [nodep-file (-> path-string? (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) From 181c8ea6dfa06836667147c98663e965f0946079 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 31 Aug 2013 06:23:49 -0600 Subject: [PATCH 333/466] include license with each package original commit: ff9da94cfb852d25cd54bc0d9a904c8ae46fe64c --- pkgs/compiler-lib/LICENSE.txt | 10 ++++++++++ pkgs/data-lib/LICENSE.txt | 10 ++++++++++ 2 files changed, 20 insertions(+) create mode 100644 pkgs/compiler-lib/LICENSE.txt create mode 100644 pkgs/data-lib/LICENSE.txt diff --git a/pkgs/compiler-lib/LICENSE.txt b/pkgs/compiler-lib/LICENSE.txt new file mode 100644 index 0000000000..f92b4cdd12 --- /dev/null +++ b/pkgs/compiler-lib/LICENSE.txt @@ -0,0 +1,10 @@ +compiler-lib +Copyright (c) 2010-2013 PLT Design Inc. + +This package is distributed under the GNU Lesser General Public +License (LGPL). This means that you can link Racket into proprietary +applications, provided you follow the rules stated in the LGPL. You +can also modify this package; if you distribute a modified version, +you must distribute it under the terms of the LGPL, which in +particular means that you must release the source code for the +modified software. See COPYING_LESSER.txt for more information. diff --git a/pkgs/data-lib/LICENSE.txt b/pkgs/data-lib/LICENSE.txt new file mode 100644 index 0000000000..75ad378a5d --- /dev/null +++ b/pkgs/data-lib/LICENSE.txt @@ -0,0 +1,10 @@ +data-lib +Copyright (c) 2010-2013 PLT Design Inc. + +This package is distributed under the GNU Lesser General Public +License (LGPL). This means that you can link Racket into proprietary +applications, provided you follow the rules stated in the LGPL. You +can also modify this package; if you distribute a modified version, +you must distribute it under the terms of the LGPL, which in +particular means that you must release the source code for the +modified software. See COPYING_LESSER.txt for more information. From b3553a342fe1ab29e7426eebd17690b3bc1ba7ab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 31 Aug 2013 11:08:20 -0600 Subject: [PATCH 334/466] move stray `rackunit` module original commit: a30d80a9c462eec96c244cb458d3297bb7e5b616 --- pkgs/compiler-lib/info.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-lib/info.rkt index 21e9cc99f3..753cd91f41 100644 --- a/pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-lib/info.rkt @@ -2,8 +2,9 @@ (define collection 'multi) -(define deps '("scheme-lib" - "base")) +(define deps '("base" + "scheme-lib" + "rackunit-lib")) (define pkg-desc "Racket compilation tools, such as `raco exe'") From 007d3fe205d8c29aa3788ae65172414729520226 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Sep 2013 09:00:42 -0400 Subject: [PATCH 335/466] Remove units in parts of `compiler`, `dynext`, `setup` and create the `cext-lib` package. `cext-lib` contains much of the contents of `dynext`, which is no longer very widely used. Also moved the implementation of the `mzc` executable to a more appropriate package. Also, used `lazy-require` consistently for dynamically loading implementations. original commit: 9f2755116dcff2a2792916eab09c50cb39113e94 --- pkgs/compiler-lib/compiler/commands/info.rkt | 1 - pkgs/compiler-lib/compiler/commands/make.rkt | 2 +- pkgs/compiler-lib/compiler/compiler-unit.rkt | 5 +++++ .../compiler-lib}/compiler/embed-sig.rkt | 0 pkgs/compiler-lib/compiler/embed-unit.rkt | 9 +++++++++ pkgs/compiler-lib/compiler/option-unit.rkt | 7 +++++++ {racket/collects => pkgs/compiler-lib}/compiler/sig.rkt | 0 .../compiler-lib}/launcher/launcher-sig.rkt | 0 pkgs/compiler-lib/launcher/launcher-unit.rkt | 7 +++++++ .../collects => pkgs/compiler-lib}/setup/option-sig.rkt | 0 pkgs/compiler-lib/setup/option-unit.rkt | 6 ++++++ pkgs/compiler-lib/setup/setup-unit.rkt | 9 +++++++++ 12 files changed, 44 insertions(+), 2 deletions(-) create mode 100644 pkgs/compiler-lib/compiler/compiler-unit.rkt rename {racket/collects => pkgs/compiler-lib}/compiler/embed-sig.rkt (100%) create mode 100644 pkgs/compiler-lib/compiler/embed-unit.rkt create mode 100644 pkgs/compiler-lib/compiler/option-unit.rkt rename {racket/collects => pkgs/compiler-lib}/compiler/sig.rkt (100%) rename {racket/collects => pkgs/compiler-lib}/launcher/launcher-sig.rkt (100%) create mode 100644 pkgs/compiler-lib/launcher/launcher-unit.rkt rename {racket/collects => pkgs/compiler-lib}/setup/option-sig.rkt (100%) create mode 100644 pkgs/compiler-lib/setup/option-unit.rkt create mode 100644 pkgs/compiler-lib/setup/setup-unit.rkt diff --git a/pkgs/compiler-lib/compiler/commands/info.rkt b/pkgs/compiler-lib/compiler/commands/info.rkt index a3f02f0725..1b766b6c9f 100644 --- a/pkgs/compiler-lib/compiler/commands/info.rkt +++ b/pkgs/compiler-lib/compiler/commands/info.rkt @@ -9,5 +9,4 @@ ("test" compiler/commands/test "run tests associated with files/directories" 15) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) - ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f) ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f))) diff --git a/pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-lib/compiler/commands/make.rkt index 622353ac7b..b998b0e7c8 100644 --- a/pkgs/compiler-lib/compiler/commands/make.rkt +++ b/pkgs/compiler-lib/compiler/commands/make.rkt @@ -2,7 +2,7 @@ (require scheme/cmdline raco/command-name compiler/cm - "../compiler.rkt" + compiler/compiler dynext/file setup/parallel-build racket/match) diff --git a/pkgs/compiler-lib/compiler/compiler-unit.rkt b/pkgs/compiler-lib/compiler/compiler-unit.rkt new file mode 100644 index 0000000000..4f6b768420 --- /dev/null +++ b/pkgs/compiler-lib/compiler/compiler-unit.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(require compiler/compiler compiler/sig racket/unit) +(provide compiler@) +(define-unit-from-context compiler@ compiler^) \ No newline at end of file diff --git a/racket/collects/compiler/embed-sig.rkt b/pkgs/compiler-lib/compiler/embed-sig.rkt similarity index 100% rename from racket/collects/compiler/embed-sig.rkt rename to pkgs/compiler-lib/compiler/embed-sig.rkt diff --git a/pkgs/compiler-lib/compiler/embed-unit.rkt b/pkgs/compiler-lib/compiler/embed-unit.rkt new file mode 100644 index 0000000000..6361ca61cd --- /dev/null +++ b/pkgs/compiler-lib/compiler/embed-unit.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(require racket/unit + racket/contract + "sig.rkt" + compiler/embed + "embed-sig.rkt") + +(define-unit-from-context compiler:embed@ compiler:embed^) +(provide compiler:embed@) diff --git a/pkgs/compiler-lib/compiler/option-unit.rkt b/pkgs/compiler-lib/compiler/option-unit.rkt new file mode 100644 index 0000000000..c0f42328b5 --- /dev/null +++ b/pkgs/compiler-lib/compiler/option-unit.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require racket/unit compiler/sig compiler/option) + +(provide compiler:option@) + +(define-unit-from-context compiler:option@ compiler:option^) diff --git a/racket/collects/compiler/sig.rkt b/pkgs/compiler-lib/compiler/sig.rkt similarity index 100% rename from racket/collects/compiler/sig.rkt rename to pkgs/compiler-lib/compiler/sig.rkt diff --git a/racket/collects/launcher/launcher-sig.rkt b/pkgs/compiler-lib/launcher/launcher-sig.rkt similarity index 100% rename from racket/collects/launcher/launcher-sig.rkt rename to pkgs/compiler-lib/launcher/launcher-sig.rkt diff --git a/pkgs/compiler-lib/launcher/launcher-unit.rkt b/pkgs/compiler-lib/launcher/launcher-unit.rkt new file mode 100644 index 0000000000..165362229c --- /dev/null +++ b/pkgs/compiler-lib/launcher/launcher-unit.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require racket/unit "launcher-sig.rkt" launcher/launcher) + +(provide launcher@) + +(define-unit-from-context launcher@ launcher^) diff --git a/racket/collects/setup/option-sig.rkt b/pkgs/compiler-lib/setup/option-sig.rkt similarity index 100% rename from racket/collects/setup/option-sig.rkt rename to pkgs/compiler-lib/setup/option-sig.rkt diff --git a/pkgs/compiler-lib/setup/option-unit.rkt b/pkgs/compiler-lib/setup/option-unit.rkt new file mode 100644 index 0000000000..1b36be3f1d --- /dev/null +++ b/pkgs/compiler-lib/setup/option-unit.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require racket/unit setup/option "option-sig.rkt") + +(provide setup:option@ set-flag-params) + +(define-unit-from-context setup:option@ setup-option^) \ No newline at end of file diff --git a/pkgs/compiler-lib/setup/setup-unit.rkt b/pkgs/compiler-lib/setup/setup-unit.rkt new file mode 100644 index 0000000000..addfd12088 --- /dev/null +++ b/pkgs/compiler-lib/setup/setup-unit.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(require racket/unit setup/setup-core) + +(provide setup@) +(define-unit setup@ + (import) + (export) + (setup-core)) From 6ebcb502de7b778bf9eec8091abb20f46a7a5135 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Oct 2013 07:09:36 -0600 Subject: [PATCH 336/466] fix .zo marshal of a syntax object containing a hash table in a list Also, fix `zo-parse` unmarshaling of syntax-object hash tables. Closes PR 14087 original commit: 70b6f6464f6064448090842daa8f49442b11b775 --- pkgs/compiler-lib/compiler/zo-parse.rkt | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/pkgs/compiler-lib/compiler/zo-parse.rkt b/pkgs/compiler-lib/compiler/zo-parse.rkt index 5d3f8dce98..ffc49b3291 100644 --- a/pkgs/compiler-lib/compiler/zo-parse.rkt +++ b/pkgs/compiler-lib/compiler/zo-parse.rkt @@ -608,24 +608,27 @@ [(pair? v) (if (eq? #t (car v)) ;; Share decoded wraps with all nested parts. - (let loop ([v (cdr v)]) + (let iloop ([v (cdr v)]) (cond [(pair? v) (let ploop ([v v]) (cond [(null? v) null] - [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] - [else (loop v)]))] - [(box? v) (add-wrap (box (loop (unbox v))))] + [(pair? v) (add-wrap (cons (iloop (car v)) (ploop (cdr v))))] + [else (iloop v)]))] + [(box? v) (add-wrap (box (iloop (unbox v))))] [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] + (add-wrap (list->vector (map iloop (vector->list v))))] + [(hash? v) + (add-wrap (for/hash ([(k v) (in-hash v)]) + (values k (iloop v))))] [(prefab-struct-key v) => (lambda (k) (add-wrap (apply make-prefab-struct k - (map loop (struct->list v)))))] + (map iloop (struct->list v)))))] [else (add-wrap v)])) ;; Decode sub-elements that have their own wraps: (let-values ([(v counter) (if (exact-integer? (car v)) @@ -641,6 +644,9 @@ [(box? v) (add-wrap (box (loop (unbox v))))] [(vector? v) (add-wrap (list->vector (map loop (vector->list v))))] + [(hash? v) + (add-wrap (for/hash ([(k v) (in-hash v)]) + (values k (loop v))))] [(prefab-struct-key v) => (lambda (k) (add-wrap From 0a855e73cf17e1723bf0fb1a474103425b5de065 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 15 Oct 2013 07:51:14 -0600 Subject: [PATCH 337/466] Base now works, but was broken before original commit: e6e95f1029b17d0a014c26cd140d5c27c2ded1a1 --- .../compiler/demodularizer/merge.rkt | 68 +++++++++++-------- .../compiler/demodularizer/nodep.rkt | 9 ++- .../compiler/demodularizer/demod-test.rkt | 8 +-- .../compiler/demodularizer/tests/base-5.rkt | 2 + 4 files changed, 52 insertions(+), 35 deletions(-) create mode 100644 pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt index 6edd751cb7..c90cdc1c1f 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt @@ -9,7 +9,7 @@ "nodep.rkt" "update-toplevels.rkt") -(define MODULE-TOPLEVEL-OFFSETS (make-hash)) +(define MODULE-TOPLEVEL-OFFSETS (make-hasheq)) (define current-get-modvar-rewrite (make-parameter #f)) (define (merge-compilation-top get-modvar-rewrite top) @@ -25,21 +25,21 @@ (log-debug (format "total toplevels ~S" total-tls)) (log-debug (format "total stxs ~S" total-stxs)) (log-debug (format "num-lifts ~S" total-lifts)) - (make-compilation-top - new-max-let-depth new-prefix + (make-compilation-top + new-max-let-depth new-prefix (make-splice (gen-new-forms new-prefix)))] [else (error 'merge "unrecognized: ~e" top)]))) (define (merge-forms max-let-depth prefix forms) (if (empty? forms) - (values max-let-depth prefix (lambda _ empty)) - (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] - [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) - (values rmax-let-depth - rprefix - (lambda args - (append (apply gen-fform args) - (apply gen-rforms args))))))) + (values max-let-depth prefix (lambda _ empty)) + (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] + [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) + (values rmax-let-depth + rprefix + (lambda args + (append (apply gen-fform args) + (apply gen-rforms args))))))) (define (merge-form max-let-depth prefix form) (match form @@ -61,16 +61,20 @@ (append root-toplevels mod-toplevels) (append root-stxs mod-stxs))])])) +(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) + (define (compute-new-modvar mv rw) (match mv [(struct module-variable (modidx sym pos phase constantness)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) (log-debug (format "Rewriting ~a of ~S" pos (mpi->path* modidx))) - ((hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx - (lambda () - (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) - (provide->toplevel sym pos))])])) + (match-define (toplevel-offset-rewriter rewrite-fun meta) + (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda () + (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) + (log-debug (format "Rewriting ~a of ~S from ~S" pos (mpi->path* modidx) meta)) + (rewrite-fun (provide->toplevel sym pos))])])) (define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) (define-values @@ -78,15 +82,15 @@ (for/fold ([i 0] [new-toplevels empty] [remap empty]) - ([tl (in-list mod-toplevels)]) + ([tl (in-list mod-toplevels)]) (match tl [(and mv (struct module-variable (modidx sym pos phase constantness))) (define rw ((current-get-modvar-rewrite) modidx)) - ; XXX We probably don't need to deal with #f phase + ; XXX We probably don't need to deal with #f phase (unless (or (not phase) (zero? phase)) (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) (cond - ; Primitive module like #%paramz + ; Primitive module like #%paramz [(symbol? rw) (log-debug (format "~S from ~S" sym rw)) (values (add1 i) @@ -106,7 +110,7 @@ (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))]))) - ; XXX This would be more efficient as a vector + ; XXX This would be more efficient as a vector (values (reverse new-toplevels) (reverse remap))) @@ -118,8 +122,9 @@ (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) - (define mod-toplevels (prefix-toplevels mod-prefix)) - (define-values (new-mod-toplevels toplevel-remap) (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) + (define mod-toplevels (prefix-toplevels mod-prefix)) + (define-values (new-mod-toplevels toplevel-remap) + (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) (define num-mod-toplevels (length toplevel-remap)) (define mod-stxs @@ -129,9 +134,16 @@ (define new-mod-prefix (struct-copy prefix mod-prefix [toplevels new-mod-toplevels])) - (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx - (lambda (n) - (list-ref toplevel-remap n))) + (define offset-meta (vector name srcname self-modidx)) + (log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S" + offset-meta + (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f)) + (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx + (toplevel-offset-rewriter + (lambda (n) + (log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta) + (list-ref toplevel-remap n)) + offset-meta)) (unless (= (length toplevel-remap) (length mod-toplevels)) (error 'merge-module "Not remapping everything: ~S ~S" @@ -142,7 +154,7 @@ (log-debug (format "[~S] Incrementing lifts by ~a" name lift-offset)) - (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" + (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" name (length mod-toplevels) (length new-mod-toplevels))) @@ -155,15 +167,15 @@ (define total-lifts (prefix-num-lifts top-prefix)) (define max-toplevel (+ top-lift-start total-lifts)) (define update - (update-toplevels + (update-toplevels (lambda (n) (cond [(mod-lift-start . <= . n) - ; This is a lift + ; This is a lift (define which-lift (- n mod-lift-start)) (define lift-tl (+ top-lift-start lift-offset which-lift)) (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) lift-tl] [else diff --git a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt index 50ca687268..75e1a4eecb 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt @@ -128,10 +128,13 @@ (when (symbol? tl) (hash-set! provide-ht (intern tl) i))) (lambda (sym pos) - (log-debug (format "Looking up ~S@~a" sym pos)) - (hash-ref provide-ht (intern sym) + (log-debug (format "Looking up ~S@~a in ~S" sym pos prefix)) + (define res + (hash-ref provide-ht (intern sym) (lambda () - (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))) + (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix)))) + (log-debug (format "Looked up ~S@~a and got ~v" sym pos res)) + res)) (define (nodep-module mod-form phase) (match mod-form diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt index a10efce85e..0fd5b24fa8 100644 --- a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt @@ -13,7 +13,7 @@ (values (get-output-string o) (get-output-string e))) (define (test-on-program filename) - ; run modular program, capture output + ;; run modular program, capture output (define-values (modular-output modular-error) (capture-output (find-exe) filename)) @@ -24,15 +24,15 @@ (find-system-path 'temp-dir) (path-add-suffix filename #"_merged.zo"))))) - ; demodularize + ;; demodularize (parameterize ([current-input-port (open-input-string "")]) (system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename)) - ; run whole program + ;; run whole program (define-values (whole-output whole-error) (capture-output (find-exe) demod-filename)) - ; compare output + ;; compare output (test #:failure-prefix (format "~a stdout" filename) whole-output => modular-output diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt new file mode 100644 index 0000000000..ea2c5d0f5e --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt @@ -0,0 +1,2 @@ +#lang racket/base +5 From 7ce8c7c434b9aaa8beb0fdadc50e58057a5873cf Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 15 Oct 2013 08:26:57 -0600 Subject: [PATCH 338/466] Racket now works, but was broken before original commit: 11b784236ed19493528a3201b55539f6b8f84c51 --- pkgs/compiler-lib/compiler/demodularizer/main.rkt | 4 ++-- pkgs/compiler-lib/compiler/demodularizer/merge.rkt | 13 +++++++++---- pkgs/compiler-lib/compiler/demodularizer/nodep.rkt | 12 +++++++----- .../tests/racket/benchmarks/shootout/nothing.rkt | 2 -- 4 files changed, 18 insertions(+), 13 deletions(-) delete mode 100644 pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/shootout/nothing.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/main.rkt b/pkgs/compiler-lib/compiler/demodularizer/main.rkt index 36e8a140fb..b6fc0989a9 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/main.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/main.rkt @@ -35,7 +35,7 @@ (path-add-suffix file-to-batch #"_merged.zo"))) ;; Transformations - (define path-cache (make-hash)) + (define path-cache (make-hasheq)) (log-info "Removing dependencies") (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) @@ -74,4 +74,4 @@ merged-zo-path (lambda () (zo-marshal-to batch-mod (current-output-port))) - #:exists 'replace)))) \ No newline at end of file + #:exists 'replace)))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt index c90cdc1c1f..04de2e30a9 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt @@ -68,13 +68,18 @@ [(struct module-variable (modidx sym pos phase constantness)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) - (log-debug (format "Rewriting ~a of ~S" pos (mpi->path* modidx))) + (log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx))) + (define tl (provide->toplevel sym pos)) + (log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl)) (match-define (toplevel-offset-rewriter rewrite-fun meta) (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx (lambda () (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) - (log-debug (format "Rewriting ~a of ~S from ~S" pos (mpi->path* modidx) meta)) - (rewrite-fun (provide->toplevel sym pos))])])) + (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta)) + (define res (rewrite-fun tl)) + (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S" + sym pos (mpi->path* modidx) tl meta res)) + res])])) (define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) (define-values @@ -86,7 +91,7 @@ (match tl [(and mv (struct module-variable (modidx sym pos phase constantness))) (define rw ((current-get-modvar-rewrite) modidx)) - ; XXX We probably don't need to deal with #f phase + ;; XXX We probably don't need to deal with #f phase (unless (or (not phase) (zero? phase)) (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) (cond diff --git a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt index 75e1a4eecb..019584d076 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt @@ -124,13 +124,14 @@ (define (construct-provide->toplevel prefix provides) (define provide-ht (make-hasheq)) (for ([tl (prefix-toplevels prefix)] - [i (in-naturals)]) + [i (in-naturals)]) (when (symbol? tl) (hash-set! provide-ht (intern tl) i))) (lambda (sym pos) - (log-debug (format "Looking up ~S@~a in ~S" sym pos prefix)) + (define isym (intern sym)) + (log-debug (format "Looking up ~S@~a [~S] in ~S" sym pos isym prefix)) (define res - (hash-ref provide-ht (intern sym) + (hash-ref provide-ht isym (lambda () (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix)))) (log-debug (format "Looked up ~S@~a and got ~v" sym pos res)) @@ -142,14 +143,15 @@ unexported max-let-depth dummy lang-info internal-context flags pre-submodules post-submodules)) (define new-prefix prefix) - ; Cache all the mpi paths + ;; Cache all the mpi paths (for-each (match-lambda [(and mv (struct module-variable (modidx sym pos phase constantness))) (mpi->path! modidx)] [tl (void)]) (prefix-toplevels new-prefix)) - (log-debug (format "[~S] module-variables: ~S" name (length (filter module-variable? (prefix-toplevels new-prefix))))) + (define mvs (filter module-variable? (prefix-toplevels new-prefix))) + (log-debug (format "[~S] module-variables: ~S - ~S" name (length mvs) mvs)) (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides)) lang-info (append (requires->modlist requires phase) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/shootout/nothing.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/shootout/nothing.rkt deleted file mode 100644 index e5a3b58314..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/shootout/nothing.rkt +++ /dev/null @@ -1,2 +0,0 @@ -#lang racket/base -1 From afe7f46d35918ae14b83ab1ac076daadf0537aef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 15 Oct 2013 16:19:27 -0600 Subject: [PATCH 339/466] move some test & doc collections out of "racket-" pkgs to new pkgs original commit: 1920ac59ab0607502641298fc575b66e6acd8c73 --- pkgs/{ => compiler-pkgs}/compiler-lib/LICENSE.txt | 0 .../compiler-lib/compiler/bundle-dist.rkt | 0 .../compiler-lib/compiler/commands/decompile.rkt | 0 .../compiler-lib/compiler/commands/exe-dir.rkt | 0 .../compiler-lib/compiler/commands/exe.rkt | 0 .../compiler-lib/compiler/commands/expand.rkt | 0 .../compiler-lib/compiler/commands/info.rkt | 0 .../compiler-lib/compiler/commands/make.rkt | 0 .../compiler-lib/compiler/commands/pack.rkt | 0 .../compiler-lib/compiler/commands/test.rkt | 0 .../compiler-lib/compiler/commands/unpack.rkt | 0 .../compiler-lib/compiler/compiler-unit.rkt | 0 .../compiler-lib/compiler/decompile.rkt | 0 .../compiler-lib/compiler/demodularizer/alpha.rkt | 0 .../compiler-lib/compiler/demodularizer/batch.rkt | 0 .../compiler/demodularizer/gc-toplevels.rkt | 0 .../compiler-lib/compiler/demodularizer/main.rkt | 0 .../compiler-lib/compiler/demodularizer/merge.rkt | 0 .../compiler-lib/compiler/demodularizer/module.rkt | 0 .../compiler-lib/compiler/demodularizer/mpi.rkt | 0 .../compiler-lib/compiler/demodularizer/nodep.rkt | 0 .../compiler/demodularizer/replace-modidx.rkt | 0 .../compiler/demodularizer/update-toplevels.rkt | 0 .../compiler-lib/compiler/demodularizer/util.rkt | 0 .../compiler-lib/compiler/embed-sig.rkt | 0 .../compiler-lib/compiler/embed-unit.rkt | 0 .../compiler-lib/compiler/option-unit.rkt | 0 .../compiler-lib/compiler/sig.rkt | 0 .../compiler-lib/compiler/zo-marshal.rkt | 0 .../compiler-lib/compiler/zo-parse.rkt | 0 .../compiler-lib/compiler/zo-structs.rkt | 0 pkgs/{ => compiler-pkgs}/compiler-lib/info.rkt | 2 +- .../compiler-lib/launcher/launcher-sig.rkt | 0 .../compiler-lib/launcher/launcher-unit.rkt | 0 .../compiler-lib/setup/option-sig.rkt | 0 .../compiler-lib/setup/option-unit.rkt | 0 .../compiler-lib/setup/setup-unit.rkt | 0 pkgs/compiler-pkgs/compiler-test/LICENSE.txt | 10 ++++++++++ pkgs/compiler-pkgs/compiler-test/info.rkt | 13 +++++++++++++ .../tests/compiler/collection-zos.rkt | 0 .../tests/compiler/demodularizer/demod-test.rkt | 0 .../tests/compiler/demodularizer/tests/base-5.rkt | 0 .../tests/compiler/demodularizer/tests/kernel-5.rkt | 0 .../tests/compiler/demodularizer/tests/racket-5.rkt | 0 .../compiler-test}/tests/compiler/regression.rkt | 0 .../compiler-test}/tests/compiler/test/a.rkt | 0 .../compiler-test}/tests/compiler/test/b.rkt | 0 .../compiler-test}/tests/compiler/test/d/c.rkt | 0 .../compiler-test}/tests/compiler/test/d/d.rkt | 0 .../compiler-test}/tests/compiler/zo-exs.rkt | 0 .../compiler-test}/tests/compiler/zo-test-util.rkt | 0 .../tests/compiler/zo-test-worker.rkt | 0 .../compiler-test}/tests/compiler/zo-test.rkt | 0 .../compiler-test}/tests/compiler/zo.rkt | 0 .../compiler}/LICENSE.txt | 2 +- pkgs/compiler-pkgs/compiler/info.rkt | 10 ++++++++++ 56 files changed, 35 insertions(+), 2 deletions(-) rename pkgs/{ => compiler-pkgs}/compiler-lib/LICENSE.txt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/bundle-dist.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/decompile.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/exe-dir.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/exe.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/expand.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/info.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/make.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/pack.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/test.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/commands/unpack.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/compiler-unit.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/decompile.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/alpha.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/batch.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/gc-toplevels.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/main.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/merge.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/module.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/mpi.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/nodep.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/replace-modidx.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/update-toplevels.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/demodularizer/util.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/embed-sig.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/embed-unit.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/option-unit.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/sig.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/zo-marshal.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/zo-parse.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/compiler/zo-structs.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/info.rkt (67%) rename pkgs/{ => compiler-pkgs}/compiler-lib/launcher/launcher-sig.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/launcher/launcher-unit.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/setup/option-sig.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/setup/option-unit.rkt (100%) rename pkgs/{ => compiler-pkgs}/compiler-lib/setup/setup-unit.rkt (100%) create mode 100644 pkgs/compiler-pkgs/compiler-test/LICENSE.txt create mode 100644 pkgs/compiler-pkgs/compiler-test/info.rkt rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/collection-zos.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/demodularizer/demod-test.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/demodularizer/tests/base-5.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/demodularizer/tests/kernel-5.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/demodularizer/tests/racket-5.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/regression.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/test/a.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/test/b.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/test/d/c.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/test/d/d.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/zo-exs.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/zo-test-util.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/zo-test-worker.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/zo-test.rkt (100%) rename pkgs/{racket-pkgs/racket-test => compiler-pkgs/compiler-test}/tests/compiler/zo.rkt (100%) rename pkgs/{data-lib => compiler-pkgs/compiler}/LICENSE.txt (98%) create mode 100644 pkgs/compiler-pkgs/compiler/info.rkt diff --git a/pkgs/compiler-lib/LICENSE.txt b/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt similarity index 100% rename from pkgs/compiler-lib/LICENSE.txt rename to pkgs/compiler-pkgs/compiler-lib/LICENSE.txt diff --git a/pkgs/compiler-lib/compiler/bundle-dist.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/bundle-dist.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/bundle-dist.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/bundle-dist.rkt diff --git a/pkgs/compiler-lib/compiler/commands/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/decompile.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt diff --git a/pkgs/compiler-lib/compiler/commands/exe-dir.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/exe-dir.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt diff --git a/pkgs/compiler-lib/compiler/commands/exe.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/exe.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt diff --git a/pkgs/compiler-lib/compiler/commands/expand.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/expand.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt diff --git a/pkgs/compiler-lib/compiler/commands/info.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/info.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt diff --git a/pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/make.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt diff --git a/pkgs/compiler-lib/compiler/commands/pack.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/pack.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt diff --git a/pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/test.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt diff --git a/pkgs/compiler-lib/compiler/commands/unpack.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/unpack.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/commands/unpack.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/commands/unpack.rkt diff --git a/pkgs/compiler-lib/compiler/compiler-unit.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/compiler-unit.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/compiler-unit.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/compiler-unit.rkt diff --git a/pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/decompile.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/alpha.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/alpha.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/alpha.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/batch.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/batch.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/main.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/main.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/main.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/main.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/merge.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/merge.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/merge.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/module.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/module.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/module.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/module.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/mpi.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/mpi.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/mpi.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/nodep.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/nodep.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/nodep.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt diff --git a/pkgs/compiler-lib/compiler/demodularizer/util.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/util.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/demodularizer/util.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/util.rkt diff --git a/pkgs/compiler-lib/compiler/embed-sig.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/embed-sig.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/embed-sig.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/embed-sig.rkt diff --git a/pkgs/compiler-lib/compiler/embed-unit.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/embed-unit.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/embed-unit.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/embed-unit.rkt diff --git a/pkgs/compiler-lib/compiler/option-unit.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/option-unit.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/option-unit.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/option-unit.rkt diff --git a/pkgs/compiler-lib/compiler/sig.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/sig.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/sig.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/sig.rkt diff --git a/pkgs/compiler-lib/compiler/zo-marshal.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/zo-marshal.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt diff --git a/pkgs/compiler-lib/compiler/zo-parse.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/zo-parse.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt diff --git a/pkgs/compiler-lib/compiler/zo-structs.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/zo-structs.rkt similarity index 100% rename from pkgs/compiler-lib/compiler/zo-structs.rkt rename to pkgs/compiler-pkgs/compiler-lib/compiler/zo-structs.rkt diff --git a/pkgs/compiler-lib/info.rkt b/pkgs/compiler-pkgs/compiler-lib/info.rkt similarity index 67% rename from pkgs/compiler-lib/info.rkt rename to pkgs/compiler-pkgs/compiler-lib/info.rkt index 753cd91f41..788fe59901 100644 --- a/pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/info.rkt @@ -6,6 +6,6 @@ "scheme-lib" "rackunit-lib")) -(define pkg-desc "Racket compilation tools, such as `raco exe'") +(define pkg-desc "implementation (no documentation) part of \"compiler\"") (define pkg-authors '(mflatt)) diff --git a/pkgs/compiler-lib/launcher/launcher-sig.rkt b/pkgs/compiler-pkgs/compiler-lib/launcher/launcher-sig.rkt similarity index 100% rename from pkgs/compiler-lib/launcher/launcher-sig.rkt rename to pkgs/compiler-pkgs/compiler-lib/launcher/launcher-sig.rkt diff --git a/pkgs/compiler-lib/launcher/launcher-unit.rkt b/pkgs/compiler-pkgs/compiler-lib/launcher/launcher-unit.rkt similarity index 100% rename from pkgs/compiler-lib/launcher/launcher-unit.rkt rename to pkgs/compiler-pkgs/compiler-lib/launcher/launcher-unit.rkt diff --git a/pkgs/compiler-lib/setup/option-sig.rkt b/pkgs/compiler-pkgs/compiler-lib/setup/option-sig.rkt similarity index 100% rename from pkgs/compiler-lib/setup/option-sig.rkt rename to pkgs/compiler-pkgs/compiler-lib/setup/option-sig.rkt diff --git a/pkgs/compiler-lib/setup/option-unit.rkt b/pkgs/compiler-pkgs/compiler-lib/setup/option-unit.rkt similarity index 100% rename from pkgs/compiler-lib/setup/option-unit.rkt rename to pkgs/compiler-pkgs/compiler-lib/setup/option-unit.rkt diff --git a/pkgs/compiler-lib/setup/setup-unit.rkt b/pkgs/compiler-pkgs/compiler-lib/setup/setup-unit.rkt similarity index 100% rename from pkgs/compiler-lib/setup/setup-unit.rkt rename to pkgs/compiler-pkgs/compiler-lib/setup/setup-unit.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt new file mode 100644 index 0000000000..7fe458f3a0 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt @@ -0,0 +1,10 @@ +compiler-test +Copyright (c) 2010-2013 PLT Design Inc. + +This package is distributed under the GNU Lesser General Public +License (LGPL). This means that you can link Racket into proprietary +applications, provided you follow the rules stated in the LGPL. You +can also modify this package; if you distribute a modified version, +you must distribute it under the terms of the LGPL, which in +particular means that you must release the source code for the +modified software. See COPYING_LESSER.txt for more information. diff --git a/pkgs/compiler-pkgs/compiler-test/info.rkt b/pkgs/compiler-pkgs/compiler-test/info.rkt new file mode 100644 index 0000000000..c053e18de7 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/info.rkt @@ -0,0 +1,13 @@ +#lang info + +(define collection 'multi) + +(define deps '("base")) + +(define pkg-desc "tests for \"compiler-lib\"") + +(define pkg-authors '(mflatt)) +(define build-deps '("compiler-lib" + "eli-tester" + "net-lib" + "scheme-lib")) diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/collection-zos.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/collection-zos.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/collection-zos.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/collection-zos.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/kernel-5.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/kernel-5.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/racket-5.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/racket-5.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/regression.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/regression.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/regression.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/regression.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/test/a.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/a.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/test/a.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/test/a.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/test/b.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/b.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/test/b.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/test/b.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/test/d/c.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/c.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/test/d/c.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/c.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/test/d/d.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/d.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/test/d/d.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/d.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/zo-exs.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-exs.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/zo-exs.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-exs.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-util.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-util.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-util.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-util.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-worker.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/zo-test-worker.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/zo-test.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/zo.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/compiler/zo.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/zo.rkt diff --git a/pkgs/data-lib/LICENSE.txt b/pkgs/compiler-pkgs/compiler/LICENSE.txt similarity index 98% rename from pkgs/data-lib/LICENSE.txt rename to pkgs/compiler-pkgs/compiler/LICENSE.txt index 75ad378a5d..f9369366b3 100644 --- a/pkgs/data-lib/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler/LICENSE.txt @@ -1,4 +1,4 @@ -data-lib +compiler Copyright (c) 2010-2013 PLT Design Inc. This package is distributed under the GNU Lesser General Public diff --git a/pkgs/compiler-pkgs/compiler/info.rkt b/pkgs/compiler-pkgs/compiler/info.rkt new file mode 100644 index 0000000000..374ab02d83 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler/info.rkt @@ -0,0 +1,10 @@ +#lang info + +(define collection 'multi) + +(define deps '("compiler-lib")) +(define implies '("compiler-lib")) + +(define pkg-desc "Racket compilation tools, such as `raco exe'") + +(define pkg-authors '(mflatt)) From dfa0381b927a2d94f1c02d81be1ab208b1eb19ed Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 7 Nov 2013 13:52:38 -0700 Subject: [PATCH 340/466] raco expand & decompile: add `--columns` option original commit: 9b04d516ba0c6a13f59447f033ddad8d992ba816 --- .../compiler-lib/compiler/commands/decompile.rkt | 15 +++++++++++---- .../compiler-lib/compiler/commands/expand.rkt | 15 +++++++++++---- 2 files changed, 22 insertions(+), 8 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt index 0bc201d044..004693fc5a 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt @@ -1,13 +1,20 @@ -#lang scheme/base -(require scheme/cmdline +#lang racket/base +(require racket/cmdline raco/command-name compiler/zo-parse compiler/decompile - scheme/pretty) + racket/pretty) (define source-files (command-line #:program (short-program+command-name) + #:once-each + [("--columns" "-n") n "Format for columns" + (let ([num (string->number n)]) + (unless (exact-positive-integer? num) + (raise-user-error (string->symbol (short-program+command-name)) + "not a valid column count: ~a" n)) + (pretty-print-columns num))] #:args source-or-bytecode-file source-or-bytecode-file)) @@ -17,7 +24,7 @@ (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))]) (parameterize ([current-load-relative-directory base] [print-graph #t]) - (pretty-print + (pretty-write (decompile (call-with-input-file* (if (file-exists? alt-file) alt-file zo-file) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt index 181b79b1c3..cb320a2a9a 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt @@ -1,11 +1,18 @@ -#lang scheme/base -(require scheme/cmdline +#lang racket/base +(require racket/cmdline raco/command-name - scheme/pretty) + racket/pretty) (define source-files (command-line #:program (short-program+command-name) + #:once-each + [("--columns" "-n") n "Format for columns" + (let ([num (string->number n)]) + (unless (exact-positive-integer? num) + (raise-user-error (string->symbol (short-program+command-name)) + "not a valid column count: ~a" n)) + (pretty-print-columns num))] #:args source-file source-file)) @@ -22,5 +29,5 @@ (let loop () (let ([e (read-syntax src-file in)]) (unless (eof-object? e) - (pretty-print (syntax->datum (expand e))) + (pretty-write (syntax->datum (expand e))) (loop)))))))))) From d0d458e1a379f9b72cda8e533e149d31994c4b22 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Nov 2013 13:21:45 -0700 Subject: [PATCH 341/466] raco exe: fix problem with dynamically resolved relative submodules original commit: 846c247aa3896ad06380ab2e89d0f36149f1260b --- pkgs/racket-pkgs/racket-test/tests/racket/embed-me23.rkt | 8 ++++++++ pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl | 8 ++++++++ 2 files changed, 16 insertions(+) create mode 100644 pkgs/racket-pkgs/racket-test/tests/racket/embed-me23.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me23.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me23.rkt new file mode 100644 index 0000000000..2f6eb92c10 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/embed-me23.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require racket/serialize) + +(serializable-struct foo (a b)) + +(define f (deserialize (serialize (foo 1 2)))) +(foo-a f) +(foo-b f) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl index 0a2527aa46..8b5e246814 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl @@ -312,6 +312,14 @@ (path->string (build-path (collection-path "tests" "racket") "embed-me22.rkt"))) (try-exe (mk-dest mred?) "Configure!\nThis is 22.\n" mred?) + ;; raco exe on a module with serialization + (system* raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "racket") "embed-me23.rkt"))) + (try-exe (mk-dest mred?) "1\n2\n" mred?) + ;; raco exe --launcher (system* raco "exe" From 15430e3fce1a9316c2b01db16847ad78a6171818 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Nov 2013 14:01:35 -0700 Subject: [PATCH 342/466] move raco exe tests to the `compiler-test` package Also, enable the `raco exe` tests for DrDr original commit: 0bc89dc6414268bc9bbe9d679cfdd213333d0430 --- pkgs/compiler-pkgs/compiler-test/info.rkt | 6 +- .../tests/compiler/embed}/embed-asl.rkt | 0 .../tests/compiler/embed}/embed-bsl.rkt | 0 .../tests/compiler/embed}/embed-bsla.rkt | 0 .../tests/compiler/embed}/embed-isl.rkt | 0 .../tests/compiler/embed}/embed-isll.rkt | 0 .../tests/compiler/embed}/embed-me1.rkt | 0 .../tests/compiler/embed}/embed-me10.rkt | 0 .../tests/compiler/embed}/embed-me11-rd.rkt | 0 .../tests/compiler/embed/embed-me11.rkt | 2 + .../tests/compiler/embed}/embed-me12-rd.ss | 0 .../tests/compiler/embed/embed-me12.ss | 2 + .../tests/compiler/embed}/embed-me13.rkt | 0 .../tests/compiler/embed}/embed-me14.rkt | 0 .../tests/compiler/embed}/embed-me15-one.rkt | 0 .../tests/compiler/embed}/embed-me15.rkt | 0 .../tests/compiler/embed}/embed-me16.rkt | 0 .../tests/compiler/embed}/embed-me17.rkt | 0 .../tests/compiler/embed}/embed-me17a.rkt | 0 .../tests/compiler/embed/embed-me18.rkt | 5 + .../tests/compiler/embed}/embed-me18a.rkt | 0 .../tests/compiler/embed}/embed-me19.rkt | 0 .../tests/compiler/embed}/embed-me1b.rkt | 0 .../tests/compiler/embed}/embed-me1c.rkt | 0 .../tests/compiler/embed}/embed-me1d.rkt | 0 .../tests/compiler/embed}/embed-me1e.rkt | 0 .../tests/compiler/embed}/embed-me2.rkt | 0 .../tests/compiler/embed}/embed-me20.rkt | 0 .../tests/compiler/embed}/embed-me21.rkt | 0 .../tests/compiler/embed}/embed-me22.rkt | 0 .../tests/compiler/embed}/embed-me23.rkt | 0 .../tests/compiler/embed}/embed-me3.rkt | 0 .../tests/compiler/embed}/embed-me4.rktl | 0 .../tests/compiler/embed}/embed-me5.rkt | 0 .../tests/compiler/embed}/embed-me6.rkt | 0 .../tests/compiler/embed}/embed-me8.c | 0 .../tests/compiler/embed}/embed-me9.rkt | 0 .../tests/compiler/embed}/embed-place.rkt | 0 .../compiler/embed}/embed-planet-1/alt.rkt | 0 .../embed}/embed-planet-1/dyn-sub.rkt | 0 .../embed}/embed-planet-1/has-sub.rkt | 0 .../compiler/embed}/embed-planet-1/main.rkt | 0 .../compiler/embed}/embed-planet-1/other.rkt | 0 .../compiler/embed}/embed-planet-2/main.ss | 0 .../embed}/embed-planet-2/private/sub.rkt | 0 .../tests/compiler/embed}/info.rkt | 0 .../tests/compiler/embed/test.rkt} | 141 ++++++++++-------- 47 files changed, 96 insertions(+), 60 deletions(-) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-asl.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-bsl.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-bsla.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-isl.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-isll.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me1.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me10.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me11-rd.rkt (100%) create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11.rkt rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me12-rd.ss (100%) create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12.ss rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me13.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me14.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me15-one.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me15.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me16.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me17.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me17a.rkt (100%) create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me18a.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me19.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me1b.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me1c.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me1d.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me1e.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me2.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me20.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me21.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me22.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me23.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me3.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me4.rktl (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me5.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me6.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me8.c (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-me9.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-place.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-planet-1/alt.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-planet-1/dyn-sub.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-planet-1/has-sub.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-planet-1/main.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-planet-1/other.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-planet-2/main.ss (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/embed-planet-2/private/sub.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler/embed}/info.rkt (100%) rename pkgs/{racket-pkgs/racket-test/tests/racket/embed.rktl => compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt} (79%) diff --git a/pkgs/compiler-pkgs/compiler-test/info.rkt b/pkgs/compiler-pkgs/compiler-test/info.rkt index c053e18de7..649a868721 100644 --- a/pkgs/compiler-pkgs/compiler-test/info.rkt +++ b/pkgs/compiler-pkgs/compiler-test/info.rkt @@ -10,4 +10,8 @@ (define build-deps '("compiler-lib" "eli-tester" "net-lib" - "scheme-lib")) + "scheme-lib" + "compatibility-lib" + "gui-lib" + "htdp-lib" + "plai")) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-asl.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-asl.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-asl.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-asl.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-bsl.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsl.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-bsl.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsl.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-bsla.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsla.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-bsla.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsla.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-isl.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isl.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-isl.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isl.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-isll.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isll.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-isll.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isll.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me1.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me10.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me10.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me11-rd.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me11-rd.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11.rkt new file mode 100644 index 0000000000..105f4033ea --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11.rkt @@ -0,0 +1,2 @@ +#reader(lib "embed-me11-rd.ss" "tests" "compiler" "embed") +"It goes to ~a!\n" diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me12-rd.ss b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me12-rd.ss rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12.ss b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12.ss new file mode 100644 index 0000000000..b1d4610954 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12.ss @@ -0,0 +1,2 @@ +#reader(lib "embed-me12-rd.rkt" "tests" "compiler" "embed") +"It goes to ~a!\n" diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me13.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me13.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me13.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me13.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me14.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me14.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me15-one.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15-one.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me15-one.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15-one.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me15.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me15.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me16.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me16.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me17.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me17.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me17a.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me17a.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt new file mode 100644 index 0000000000..f169efab51 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require (submod tests/compiler/embed/embed-me18a sub)) +(with-output-to-file "stdout" + (dynamic-require '(submod tests/compiler/embed/embed-me18a sub) 'print-18) + #:exists 'append) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me18a.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18a.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me18a.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18a.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me19.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me19.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1b.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me1b.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1c.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me1c.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1d.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me1d.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me1e.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me1e.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me2.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me2.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me20.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me20.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me21.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me21.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me22.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me22.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me22.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me22.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me23.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me23.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me23.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me23.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me3.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me3.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me4.rktl b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me4.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me4.rktl rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me4.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me5.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me5.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me6.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me6.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me8.c b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me8.c similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me8.c rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me8.c diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-me9.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-me9.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-place.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-place.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-place.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-place.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/alt.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/alt.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/dyn-sub.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/dyn-sub.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/has-sub.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/has-sub.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/main.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/main.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/other.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-1/other.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/main.ss b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/main.ss rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/private/sub.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed-planet-2/private/sub.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/info.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/info.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt similarity index 79% rename from pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt index 8b5e246814..e82a2de4cb 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/embed.rktl +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt @@ -1,7 +1,4 @@ - -(load-relative "loadtest.rktl") - -(Section 'embed) +#lang racket/base (require compiler/embed mzlib/file @@ -9,6 +6,14 @@ launcher compiler/distribute) +(define (test expect f/label . args) + (define r (apply (if (procedure? f/label) + f/label + values) + args)) + (unless (equal? expect r) + (error "failed\n"))) + (define (mk-dest-bin mred?) (case (system-type) [(windows) "e.exe"] @@ -108,16 +113,16 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "racket"))) + `((#t (lib ,filename "tests" "compiler" "embed"))) null #f - `(,(flags "l") ,(string-append "tests/racket/" filename))) + `(,(flags "l") ,(string-append "tests/compiler/embed/" filename))) (try-exe dest expect mred?) ;; As a launcher: (prepare dest filename) ((if mred? make-gracket-launcher make-racket-launcher) - (list "-l" (string-append "tests/racket/" filename)) + (list "-l" (string-append "tests/compiler/embed/" filename)) dest) (try-exe dest expect mred? #:dist? #f) @@ -128,7 +133,7 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((,pfx (lib ,filename "tests" "racket")) + `((,pfx (lib ,filename "tests" "compiler" "embed")) (#t (lib "scheme/init"))) null #f @@ -145,7 +150,7 @@ ;; Try full path, and use literal S-exp to start (printf ">>>literal sexp\n") (prepare dest filename) - (let ([path (build-path (collection-path "tests" "racket") filename)]) + (let ([path (build-path (collection-path "tests" "compiler" "embed") filename)]) (make-embedding-executable dest mred? #f `((#t ,path)) @@ -158,7 +163,7 @@ ;; Use `file' form: (printf ">>>file\n") (prepare dest filename) - (let ([path (build-path (collection-path "tests" "racket") filename)]) + (let ([path (build-path (collection-path "tests" "compiler" "embed") filename)]) (make-embedding-executable dest mred? #f `((#t (file ,(path->string path)))) @@ -171,7 +176,7 @@ ;; Use relative path (printf ">>>relative path\n") (prepare dest filename) - (parameterize ([current-directory (collection-path "tests" "racket")]) + (parameterize ([current-directory (collection-path "tests" "compiler" "embed")]) (make-embedding-executable dest mred? #f `((#f ,filename)) @@ -186,13 +191,13 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "racket")) - (#t (lib "embed-me3.rkt" "tests" "racket"))) + `((#t (lib ,filename "tests" "compiler" "embed")) + (#t (lib "embed-me3.rkt" "tests" "compiler" "embed"))) null (base-compile `(begin - (namespace-require '(lib "embed-me3.rkt" "tests" "racket")) - (namespace-require '(lib ,filename "tests" "racket")))) + (namespace-require '(lib "embed-me3.rkt" "tests" "compiler" "embed")) + (namespace-require '(lib ,filename "tests" "compiler" "embed")))) `(,(flags ""))) (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) @@ -207,14 +212,14 @@ '(namespace-require ''#%kernel))))) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "racket"))) + `((#t (lib ,filename "tests" "compiler" "embed"))) (list tmp - (build-path (collection-path "tests" "racket") "embed-me4.rktl")) + (build-path (collection-path "tests" "compiler" "embed") "embed-me4.rktl")) `(with-output-to-file "stdout" (lambda () (display "... and more!\n")) 'append) - `(,(flags "l") ,(string-append "tests/racket/" filename))) + `(,(flags "l") ,(string-append "tests/compiler/embed/" filename))) (delete-file tmp)) (try-exe dest (string-append "This is the literal expression 4.\n" @@ -223,18 +228,19 @@ mred?))) (one-mz-test "embed-me1.rkt" "This is 1\n" #t) - (one-mz-test "embed-me1b.rkt" "This is 1b\n" #f) - (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f) - (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) - (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) - (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) - (one-mz-test "embed-me13.rkt" "This is 14\n" #f) - (one-mz-test "embed-me14.rkt" "This is 14\n" #f) - (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) - (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) - (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) - (one-mz-test "embed-me19.rkt" "This is 19.\n" #f) - (one-mz-test "embed-me21.rkt" "This is 21.\n" #f) + (unless mred? + (one-mz-test "embed-me1b.rkt" "This is 1b\n" #f) + (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f) + (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) + (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) + (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) + (one-mz-test "embed-me13.rkt" "This is 14\n" #f) + (one-mz-test "embed-me14.rkt" "This is 14\n" #f) + (one-mz-test "embed-me15.rkt" "This is 15.\n" #f) + (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) + (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) + (one-mz-test "embed-me19.rkt" "This is 19.\n" #f) + (one-mz-test "embed-me21.rkt" "This is 21.\n" #f)) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -261,10 +267,10 @@ (prepare mr-dest "embed-me5.rkt") (make-embedding-executable mr-dest #t #f - `((#t (lib "embed-me5.rkt" "tests" "racket"))) + `((#t (lib "embed-me5.rkt" "tests" "compiler" "embed"))) null #f - `("-l" "tests/racket/embed-me5.rkt")) + `("-l" "tests/compiler/embed/embed-me5.rkt")) (try-exe mr-dest "This is 5: #\n" #t))) ;; Try the raco interface: @@ -277,7 +283,7 @@ "raco.exe" "raco"))) -(define (mzc-tests mred?) +(define (short-mzc-tests mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) ;; raco exe @@ -285,7 +291,7 @@ "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") - (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) ;; raco exe on a module with a `main' submodule @@ -293,7 +299,27 @@ "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") - (path->string (build-path (collection-path "tests" "racket") "embed-me16.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me16.rkt"))) + (try-exe (mk-dest mred?) "This is 16.\n" mred?))) + +(define (mzc-tests mred?) + (short-mzc-tests mred?) + (parameterize ([current-directory (find-system-path 'temp-dir)]) + + ;; raco exe + (system* raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) + (try-exe (mk-dest mred?) "This is 1\n" mred?) + + ;; raco exe on a module with a `main' submodule + (system* raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me16.rkt"))) (try-exe (mk-dest mred?) "This is 16.\n" mred?) ;; raco exe on a module with a `main' submodule+ @@ -301,7 +327,7 @@ "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") - (path->string (build-path (collection-path "tests" "racket") "embed-me20.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me20.rkt"))) (try-exe (mk-dest mred?) "This is 20.\n" mred?) ;; raco exe on a module with a `configure-runtime' submodule @@ -309,7 +335,7 @@ "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") - (path->string (build-path (collection-path "tests" "racket") "embed-me22.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me22.rkt"))) (try-exe (mk-dest mred?) "Configure!\nThis is 22.\n" mred?) ;; raco exe on a module with serialization @@ -317,7 +343,7 @@ "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") - (path->string (build-path (collection-path "tests" "racket") "embed-me23.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me23.rkt"))) (try-exe (mk-dest mred?) "1\n2\n" mred?) ;; raco exe --launcher @@ -326,7 +352,7 @@ "--launcher" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") - (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred? #:dist? #f) ;; the rest use mzc... @@ -334,7 +360,7 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) ;; Check that etc.rkt isn't found if it's not included: @@ -342,7 +368,7 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) ;; And it is found if it is included: @@ -351,7 +377,7 @@ (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "++lib" "mzlib/etc.rkt" - (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Or, it's found if we set the collection path: @@ -361,7 +387,7 @@ (path->string (mk-dest mred?)) "--collects-path" (path->string (find-collects-dir)) - (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) ;; Don't try a distribution for this one: (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) @@ -373,7 +399,7 @@ "++lib" "mzlib/etc.rkt" "--collects-dest" "cts" "--collects-path" "cts" - (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (test #f system* (mk-dest mred?)) @@ -382,7 +408,7 @@ (define (try-mzc) (mzc-tests #f) - (mzc-tests #t)) + (short-mzc-tests #t)) (require dynext/file) (define (extension-test mred?) @@ -411,7 +437,7 @@ (system* mzc "--cc" "-d" (path->string (path-only obj-file)) - (path->string (build-path (collection-path "tests" "racket") "embed-me8.c"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me8.c"))) (system* mzc "--ld" (path->string ext-file) @@ -419,7 +445,7 @@ (when (file-exists? ss-file) (delete-file ss-file)) - (copy-file (build-path (collection-path "tests" "racket") "embed-me9.rkt") + (copy-file (build-path (collection-path "tests" "compiler" "embed") "embed-me9.rkt") ss-file) (system* mzc @@ -436,7 +462,7 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me10.rkt"))) (try-exe (mk-dest mred?) "#t\n" mred?))) (define (try-extension) @@ -449,7 +475,7 @@ (system* mzc "--gui-exe" (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me5.rkt"))) (try-exe (mk-dest #t) "This is 5: #\n" #t))) ;; Try including source that needs a reader extension @@ -468,8 +494,8 @@ (create-embedding-executable dest - #:modules `((#t (lib ,filename "tests" "racket"))) - #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename)) + #:modules `((#t (lib ,filename "tests" "compiler" "embed"))) + #:cmdline `(,(flags "l") ,(string-append "tests/compiler/embed/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) (equal? name (path-replace-suffix (string->path filename) @@ -483,7 +509,8 @@ "embed-me~a-rd.rkt") (if 12? "12" "11")) "tests" - "racket")) + "compiler" + "embed")) null))) #:mred? mred?) @@ -506,9 +533,9 @@ (define (try-planet) (system* raco "planet" "link" "racket-tester" "p1.plt" "1" "0" - (path->string (collection-path "tests" "racket" "embed-planet-1"))) + (path->string (collection-path "tests" "compiler" "embed" "embed-planet-1"))) (system* raco "planet" "link" "racket-tester" "p2.plt" "2" "2" - (path->string (collection-path "tests" "racket" "embed-planet-2"))) + (path->string (collection-path "tests" "compiler" "embed" "embed-planet-2"))) (let ([go (lambda (path expected) (printf "Trying planet ~s...\n" path) @@ -553,7 +580,7 @@ "exe" "-o" exe "--" - (path->string (build-path (collection-path "tests" "racket") src))) + (path->string (build-path (collection-path "tests" "compiler" "embed") src))) (try-exe exe "10\n" #f)) (try-one "embed-bsl.rkt") @@ -571,7 +598,3 @@ (try-reader) (try-planet) (try-*sl) - -;; ---------------------------------------- - -(report-errs) From 758ee94a4104dc10e348a453951f58240b944abd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Nov 2013 21:42:17 -0700 Subject: [PATCH 343/466] "racket-test" clean-up Move a few tests, and clear out a lot of junk. original commit: 29a0c44c98d5c8d3660e4bd10eb566c7ec6e46e2 --- .../compiler-test/tests/compiler}/ctool.rkt | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename pkgs/{racket-pkgs/racket-test/tests/racket => compiler-pkgs/compiler-test/tests/compiler}/ctool.rkt (100%) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ctool.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/ctool.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/ctool.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/ctool.rkt From f35ba28b1f9fc7654e97d3ac6255e2b574a4a2ca Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 19 Nov 2013 13:22:41 -0700 Subject: [PATCH 344/466] Fix PR14175 original commit: 80ba30eaaba6fd9c0b96d0194b1c1bbbf44a7ae6 --- .../compiler-lib/compiler/commands/test.rkt | 21 ++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index b43c38f8f4..036ee9d4a5 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -129,6 +129,7 @@ (module paths racket/base (require setup/link + racket/match racket/list) (struct col (name path) #:transparent) @@ -138,10 +139,14 @@ (and version? (regexp-quote (version)))) (append - (for/list ([c+p (in-list (links #:user? user? #:version-regexp version-re #:with-path? #t))]) + (for/list ([c+p + (in-list + (links #:user? user? #:version-regexp version-re #:with-path? #t))]) (col (car c+p) (cdr c+p))) - (for/list ([cp (in-list (links #:root? #t #:user? user? #:version-regexp version-re))] + (for/list ([cp + (in-list + (links #:root? #t #:user? user? #:version-regexp version-re))] #:when (directory-exists? cp) [collection (directory-list cp)] #:when (directory-exists? (build-path cp collection))) @@ -166,9 +171,15 @@ ;; This should be in Racket somewhere and return all the collection ;; paths, rather than just the first as collection-path does. (define (collection-paths c) - (for/list ([col (all-collections)] - #:when (string=? c (col-name col))) - (col-path col))) + (match-define (list-rest sc more) (map path->string (explode-path c))) + (append* + (for/list ([col (all-collections)] + #:when (string=? sc (col-name col))) + (define p (col-path col)) + (define cp (apply build-path p more)) + (if (directory-exists? cp) + (list cp) + empty)))) (provide collection-paths)) From b94fd95bbfd211eab814da9b45251139d3727ddc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 19 Nov 2013 14:20:59 -0700 Subject: [PATCH 345/466] Continue fixing PR14175 by looking at all links files original commit: 8e2622857f1470fdf4f5a7ec80d0385457240d62 --- .../compiler-lib/compiler/commands/test.rkt | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 036ee9d4a5..0048800ca3 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -134,19 +134,21 @@ (struct col (name path) #:transparent) - (define (get-linked user? version?) + (define (get-linked file user? version?) (define version-re (and version? (regexp-quote (version)))) (append (for/list ([c+p (in-list - (links #:user? user? #:version-regexp version-re #:with-path? #t))]) + (links #:file file #:user? user? #:version-regexp version-re + #:with-path? #t))]) (col (car c+p) (cdr c+p))) (for/list ([cp (in-list - (links #:root? #t #:user? user? #:version-regexp version-re))] + (links #:file file #:user? user? #:version-regexp version-re + #:root? #t))] #:when (directory-exists? cp) [collection (directory-list cp)] #:when (directory-exists? (build-path cp collection))) @@ -164,9 +166,10 @@ #:when (directory-exists? (build-path cp collection))) (col (path->string collection) (build-path cp collection))) - (for*/list ([user? (in-list '(#t #f))] + (for*/list ([file (in-list (current-library-collection-links))] + [user? (in-list '(#t #f))] [version? (in-list '(#t #f))]) - (get-linked user? version?))))) + (get-linked file user? version?))))) ;; This should be in Racket somewhere and return all the collection ;; paths, rather than just the first as collection-path does. From 88c3578e5272b8fdc7a24af11b8c690c113e2960 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 29 Nov 2013 10:18:10 -0700 Subject: [PATCH 346/466] raco exe: add `--config-path` option, default to "etc" Make executables created by `raco exe` not refer to the original configuration directory by default, but add an option for setting the directory. For Unix ELF executables, fix `raco exe` to set/preserve the configuration directory. Merge to v6.0 original commit: 33b7d49b2ec2314c251af0992d497908229b9270 --- .../compiler-lib/compiler/commands/exe.rkt | 6 +- .../tests/compiler/embed/embed-me6b.rkt | 8 ++ .../tests/compiler/embed/test.rkt | 92 +++++++++++-------- 3 files changed, 68 insertions(+), 38 deletions(-) create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt index cdea3a3153..e1241b11f1 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt @@ -16,6 +16,7 @@ (define exe-embedded-flags (make-parameter '("-U" "--"))) (define exe-embedded-libraries (make-parameter null)) (define exe-aux (make-parameter null)) +(define exe-embedded-config-path (make-parameter "etc")) (define exe-embedded-collects-path (make-parameter null)) (define exe-embedded-collects-dest (make-parameter #f)) @@ -29,6 +30,8 @@ (gui #t)] [("-l" "--launcher") "Generate a launcher" (launcher #t)] + [("--config-path") path "Set as configuration directory for executable" + (exe-embedded-config-path path)] [("--collects-path") path "Set as main collects for executable" (exe-embedded-collects-path path)] [("--collects-dest") dir "Write collection code to " @@ -133,6 +136,7 @@ #:cmdline (exe-embedded-flags) #:collects-path (exe-embedded-collects-path) #:collects-dest (exe-embedded-collects-dest) - #:aux (exe-aux))]) + #:aux (cons `(config-dir . ,(exe-embedded-config-path)) + (exe-aux)))]) (when (verbose) (printf " [output to \"~a\"]\n" dest))) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt new file mode 100644 index 0000000000..839af8e0b3 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt @@ -0,0 +1,8 @@ +(module embed-me6b racket/base + (with-output-to-file "stdout" + (lambda () + (printf "This is 6\n") + (with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))]) + (printf "~a\n" (and (dynamic-require 'racket/fixnum #f) #t)))) + #:exists 'append)) + diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt index e82a2de4cb..a1e8945895 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt @@ -363,46 +363,64 @@ (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) - ;; Check that etc.rkt isn't found if it's not included: - (printf ">>not included\n") - (system* mzc - (if mred? "--gui-exe" "--exe") - (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) - (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) + (define (check-collection-path prog lib in-main?) + ;; Check that etc.rkt isn't found if it's not included: + (printf ">>not included\n") + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) - ;; And it is found if it is included: - (printf ">>included\n") - (system* mzc - (if mred? "--gui-exe" "--exe") - (path->string (mk-dest mred?)) - "++lib" "mzlib/etc.rkt" - (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) - (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + ;; And it is found if it is included: + (printf ">>included\n") + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "++lib" lib + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) - ;; Or, it's found if we set the collection path: - (printf ">>set coll path\n") - (system* mzc - (if mred? "--gui-exe" "--exe") - (path->string (mk-dest mred?)) - "--collects-path" - (path->string (find-collects-dir)) - (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) - ;; Don't try a distribution for this one: - (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + ;; Or, it's found if we set the collection path and the config path (where the latter + ;; finds links for packages): + (printf ">>set coll path\n") + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "--collects-path" + (path->string (find-collects-dir)) + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + ;; Don't try a distribution for this one: + (try-one-exe (mk-dest mred?) (if in-main? "This is 6\n#t\n" "This is 6\nno etc.ss\n") mred?) - ;; Try --collects-dest mode - (printf ">>--collects-dest\n") - (system* mzc - (if mred? "--gui-exe" "--exe") - (path->string (mk-dest mred?)) - "++lib" "mzlib/etc.rkt" - "--collects-dest" "cts" - "--collects-path" "cts" - (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me6.rkt"))) - (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution - (delete-directory/files "cts") - (test #f system* (mk-dest mred?)) + ;; Or, it's found if we set the collection path and the config path (where the latter + ;; finds links for packages): + (printf ">>set coll path plus config\n") + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "--collects-path" + (path->string (find-collects-dir)) + "--config-path" + (path->string (find-config-dir)) + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + ;; Don't try a distribution for this one: + (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) + + ;; Try --collects-dest mode + (printf ">>--collects-dest\n") + (system* mzc + (if mred? "--gui-exe" "--exe") + (path->string (mk-dest mred?)) + "++lib" lib + "--collects-dest" "cts" + "--collects-path" "cts" + (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) + (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution + (delete-directory/files "cts") + (test #f system* (mk-dest mred?))) + (check-collection-path "embed-me6b.rkt" "racket/fixnum.rkt" #t) + (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" #f) (void))) From 9101bccd5b3438fdb734a4311f0ab825a48a5894 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 30 Nov 2013 08:07:32 -0700 Subject: [PATCH 347/466] raco exe: suppress expected stderr output Merge to v6.0 original commit: fd2da02029bd6a31b48ee9dfa2ff836b45fc1291 --- .../compiler-test/tests/compiler/embed/test.rkt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt index a1e8945895..6588421ca8 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt @@ -1,8 +1,9 @@ #lang racket/base (require compiler/embed - mzlib/file - mzlib/process + racket/file + racket/system + racket/port launcher compiler/distribute) @@ -418,7 +419,8 @@ (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") - (test #f system* (mk-dest mred?))) + (parameterize ([current-error-port (open-output-nowhere)]) + (test #f system* (mk-dest mred?)))) (check-collection-path "embed-me6b.rkt" "racket/fixnum.rkt" #t) (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" #f) From 92481e65d33f8a2518ef2c598da2d34b0516007c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 28 Dec 2013 19:48:10 -0600 Subject: [PATCH 348/466] raco test: add DrDr-like modes Run tests in separate processes, support tests in parallel, flag tests with non-zero exit codes or stderr output as failing, add timeout support, etc. Use the `--drdr` flag as a shorthand for DrDr-like flags. The `--drdr` flag causes `raco test` to check for a `drdr` submodule, then a `test` submodule, then run the module directly. (The idea is that DrDr will eventualy try the same sequence.) A test can declare an alternate timeout through a `config` sub-submodule (and the idea is that "props" will go away). original commit: 0db19423b41d5cf8aabda8e8ffc4840c108a384a --- .../compiler-lib/compiler/commands/test.rkt | 405 +++++++++++++++--- 1 file changed, 347 insertions(+), 58 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 0048800ca3..8564b55810 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -6,40 +6,199 @@ racket/function racket/port racket/path + racket/place + racket/future + compiler/find-exe raco/command-name + racket/system rackunit/log pkg/lib) (define submodules '()) +(define first-avail? #f) (define run-anyways? #t) (define quiet? #f) (define quiet-program? #f) (define table? #f) -(define (dynamic-require* p d) - (parameterize - ([current-output-port - (if quiet-program? - (open-output-nowhere) - (current-output-port))] - [current-error-port - (if quiet-program? - (open-output-nowhere) - (current-error-port))]) - (dynamic-require p d))) +(define jobs 0) +(define task-sema (make-semaphore 1)) +(define default-timeout +inf.0) +(define default-mode 'process) + +;; Stub for running a test in a place: +(module start racket/base + (require racket/place + rackunit/log) + (provide go) + (define (go pch) + (define l (place-channel-get pch)) + ;; Run the test: + (parameterize ([current-command-line-arguments '#()] + [current-directory (caddr l)]) + (dynamic-require (car l) (cadr l))) + ;; If the tests use `rackunit`, collect result stats: + (define test-results + (test-log #:display? #f #:exit? #f)) + ;; Return test results. If we don't get this far, the result + ;; code of the place determines whether it the test counts as + ;; successful. + (place-channel-put pch + ;; If the test did not use `rackunit`, claim + ;; success: + (if (zero? (car test-results)) + (cons 0 1) + test-results)))) + +;; Run each test in its own place or process, and collect both test +;; results and whether any output went to stderr. +(define (dynamic-require-elsewhere p d + #:mode [mode default-mode] + #:timeout [timeout default-timeout]) + (define c (make-custodian)) + (with-handlers ([exn:fail? (lambda (exn) + (custodian-shutdown-all c) + (unless quiet? + (eprintf "~a: ~a\n" + (extract-file-name p) + (exn-message exn))) + (summary 1 1 (current-label) #f))]) + (define e (open-output-bytes)) + + (define stdout (if quiet-program? + (open-output-nowhere) + (current-output-port))) + (define stderr (if quiet-program? + e + (tee-output-port (current-error-port) e))) + + (define-values (result-code test-results) + (case mode + [(place) + ;; Start the test place: + (define-values (pl in out/f err/f) + (parameterize ([current-custodian c]) + (dynamic-place* '(submod compiler/commands/test start) + 'go + #:in (current-input-port) + #:out stdout + #:err stderr))) + + ;; Send the module path to test: + (place-channel-put pl (list p d (current-directory))) + + ;; Wait for the place to finish: + (unless (sync/timeout timeout (place-dead-evt pl)) + (error 'test "timeout after ~a seconds" timeout)) + + ;; Get result code and test results: + (values (place-wait pl) + (sync/timeout 0 pl))] + [(process) + (define ps + (parameterize ([current-output-port stdout] + [current-error-port stderr] + [current-subprocess-custodian-mode 'kill] + [current-custodian c]) + (process*/ports stdout + (current-input-port) + stderr + (find-exe) + "-l" + "racket/base" + "-e" + (format "(dynamic-require '~s ~s)" + (normalize-module-path p) + d)))) + (define proc (list-ref ps 4)) + + (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) + (error 'test "timeout after ~a seconds" timeout)) + + (values (proc 'exit-code) + #f)])) + + ;; Shut down the place/process (usually a no-op unless it timed out): + (custodian-shutdown-all c) + + ;; Check results: + (unless (equal? #"" (get-output-bytes e)) + (error 'test "non-empty stderr: ~e" (get-output-bytes e))) + (unless (zero? result-code) + (error 'test "non-zero exit: ~e" result-code)) + (cond + [test-results + (summary (car test-results) (cdr test-results) (current-label) #f)] + [else + (summary 0 1 (current-label) #f)]))) + +;; For recording stderr while also propagating to the original stderr: +(define (tee-output-port p1 p2) + (make-output-port + (object-name p1) + p1 + (lambda (bstr start end non-block? enable-break?) + (cond + [(= start end) + (flush-output p1) + 0] + [else + (define n (write-bytes-avail* bstr p1 start end)) + (cond + [(or (not n) + (zero? n)) + (wrap-evt p1 (lambda (v) 0))] + [else + (write-bytes bstr p2 start (+ start n)) + n])])) + (lambda () + (close-output-port p1) + (close-output-port p2)))) + +(define (extract-file-name p) + (cond + [(and (pair? p) (eq? 'submod (car p))) + (cadr p)] + [else p])) + +(define (add-submod mod sm) + (if (and (pair? mod) (eq? 'submod (car mod))) + (append mod '(config)) + (error 'test "cannot add test-config submodule to path: ~s" mod))) + +(define (dynamic-require* p d try-config?) + (define lookup + (or (cond + [(not try-config?) #f] + [(module-declared? (add-submod p 'config) #t) + (dynamic-require (add-submod p 'config) '#%info-lookup)] + [else #f]) + (lambda (what get-default) (get-default)))) + (dynamic-require-elsewhere + p d + #:timeout (lookup 'timeout + (lambda () default-timeout)))) + +(define current-label (make-parameter "???")) (struct summary (failed total label body-res)) + (define-syntax-rule (with-summary label . body) - (let () - (match-define (cons before-failed before-total) - (test-log #:display? #f #:exit? #f)) - (define res (begin . body)) - (match-define (cons after-failed after-total) - (test-log #:display? #f #:exit? #f)) - (summary (- after-failed before-failed) - (- after-total before-total) - label - res))) + (call-with-summary label (lambda () . body))) + +(define (call-with-summary label thunk) + (define res + ;; Produces either a summary or a list of summary: + (parameterize ([current-label label]) + (thunk))) + (if (summary? res) + res + (summary + (apply + (map summary-failed res)) + (apply + (map summary-total res)) + (current-label) + res))) + (define (iprintf i fmt . more) (for ([j (in-range i)]) @@ -68,7 +227,7 @@ (define (max-width f) (string-length (number->string - (apply max (map f sfiles))))) + (apply max 0 (map f sfiles))))) (define failed-wid (max-width summary-failed)) (define total-wid (max-width summary-total)) (for ([f (in-list sfiles)]) @@ -84,48 +243,133 @@ total) " " p)))) -(define (do-test e [check-suffix? #f]) +;; Like `map`, but allows `run-one-test`s in parallel while starting +;; tasks in the order that a plain `map` would run them. The #:sema +;; argument everywhere makes tests start in a deterministic order +;; and keeps a filesystem traversal from getting far ahead of the +;; test runs. +(define (map/parallel f l #:sema continue-sema) + (cond + [(jobs . <= . 1) (map (lambda (v) (f v #:sema continue-sema)) l)] + [else + (struct task (th result-box)) + (define ts + (for/list ([i (in-list l)]) + (define b (box #f)) + (define c-sema (make-semaphore)) + (define t (thread + (lambda () + (set-box! b (with-handlers ([exn? values]) + (f i #:sema c-sema))) + ;; If no parallel task was ever created, + ;; count that as progress to the parent + ;; thread: + (semaphore-post c-sema)))) + (sync c-sema) + (task t b))) + (semaphore-post continue-sema) + (map sync (map task-th ts)) + (for/list ([t (in-list ts)]) + (define v (unbox (task-result-box t))) + (if (exn? v) + (raise v) + v))])) + +(define (normalize-module-path p) + (cond + [(path? p) (path->string p)] + [(and (pair? p) (eq? 'submod (car p))) + (list* 'submod (normalize-module-path (cadr p)) (cddr p))] + [else p])) + +(define ids '(1)) +(define ids-lock (make-semaphore 1)) + +(define (set-jobs! n) + (set! jobs n) + (set! task-sema (make-semaphore jobs)) + (set! ids (for/list ([i (in-range jobs)]) i))) + +;; Perform test of one module (in parallel, as allowed by +;; `task-sema`): +(define (test-module p mod try-config? #:sema continue-sema) + (call-with-semaphore + task-sema ; limits parallelism + (lambda () + (semaphore-post continue-sema) ; allow next to try to start + (define id + (call-with-semaphore + ids-lock + (lambda () + (define id (car ids)) + (set! ids (cdr ids)) + (unless quiet? + ;; in lock, so printouts are not interleaved + (printf "raco test: ~a~s\n" + (if (jobs . <= . 1) + "" + (format "~a " id)) + (let ([m (normalize-module-path p)]) + (if (and (pair? mod) (eq? 'submod (car mod))) + (list* 'submod m (cddr mod)) + m)))) + id))) + (begin0 + (dynamic-require* mod 0 try-config?) + (call-with-semaphore + ids-lock + (lambda () + (set! ids (cons id ids)))))))) + +;; Perform all tests in path `e`: +(define (test-files e [check-suffix? #f] #:sema continue-sema) (match e [(? string? s) - (do-test (string->path s))] + (test-files (string->path s) check-suffix? #:sema continue-sema)] [(? path? p) (cond [(directory-exists? p) (with-summary `(directory ,p) - (map - (λ (dp) - (do-test (build-path p dp) #t)) - (directory-list p)))] + (map/parallel + (λ (dp #:sema s) + (test-files (build-path p dp) #t #:sema s)) + (directory-list p) + #:sema continue-sema))] [(and (file-exists? p) (or (not check-suffix?) (regexp-match #rx#"\\.rkt$" (path->bytes p)))) - (with-summary - `(file ,p) - (parameterize ([current-command-line-arguments '#()]) - (define something-wasnt-declared? #f) - (for ([submodule (in-list (if (null? submodules) - '(test) - (reverse submodules)))]) - (define mod `(submod ,p ,submodule)) - (cond - [(module-declared? mod #t) - (unless quiet? - (printf "raco test: ~s\n" `(submod ,(if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)) - ,submodule))) - (dynamic-require* mod 0)] - [else - (set! something-wasnt-declared? #t)])) - (when (and run-anyways? something-wasnt-declared?) - (unless quiet? - (printf "raco test: ~s\n" (if (absolute-path? p) - `(file ,(path->string p)) - (path->string p)))) - (dynamic-require* p 0))))] + (parameterize ([current-directory (let-values ([(base name dir?) (split-path p)]) + (if (path? base) + base + (current-directory)))]) + (define file-name (file-name-from-path p)) + (with-summary + `(file ,p) + (let ([something-wasnt-declared? #f] + [did-one? #f]) + (filter + values + (append + (for/list ([submodule (in-list (if (null? submodules) + '(test) + (reverse submodules)))]) + (define mod `(submod ,file-name ,submodule)) + (cond + [(and did-one? first-avail?) + #f] + [(module-declared? mod #t) + (set! did-one? #t) + (test-module p mod #t #:sema continue-sema)] + [else + (set! something-wasnt-declared? #t) + #f])) + (list + (and (and run-anyways? something-wasnt-declared?) + (test-module p file-name #f #:sema continue-sema))))))))] [(not (file-exists? p)) - (error 'test "given path ~e does not exist" p)])])) + (error 'test "given path ~e does not exist" p)] + [else (summary 0 0 #f null)])])) (module paths racket/base (require setup/link @@ -191,7 +435,7 @@ (define collections? #f) (define packages? #f) -(define (do-test-wrap e) +(define (test-top e #:sema continue-sema) (cond [collections? (match (collection-paths e) @@ -200,19 +444,40 @@ [l (with-summary `(collection ,e) - (map do-test l))])] + (map/parallel test-files l #:sema continue-sema))])] [packages? (define pd (pkg-directory e)) (if pd (with-summary `(package ,e) - (do-test pd)) + (test-files pd #:sema continue-sema)) (error 'test "Package ~e is not installed" e))] [else - (do-test e)])) + (test-files e #:sema continue-sema)])) + +(define (string->number* what s check) + (define n (string->number s)) + (unless (check n) + (raise-user-error (string->symbol (short-program+command-name)) + "invalid ~a: ~s" + what + s)) + n) (command-line #:program (short-program+command-name) + #:once-each + [("--drdr") + "Configure defaults to imitate DrDr" + (when (null? submodules) + (set! submodules '(drdr test))) + (set! first-avail? #t) + (when (zero? jobs) + (set-jobs! (processor-count))) + (when (equal? default-timeout +inf.0) + (set! default-timeout 600)) + (set! quiet-program? #t) + (set! table? #t)] #:multi [("--submodule" "-s") name "Runs submodule \n (defaults to running just the `test' submodule)" @@ -226,6 +491,9 @@ "Require nothing if submodule is absent" (set! run-anyways? #f)] #:once-each + [("--first-avail") + "Run only the first available submodule" + (set! first-avail? #f)] [("--quiet" "-q") "Suppress `raco test: ...' message" (set! quiet? #t)] @@ -235,6 +503,15 @@ [("--quiet-program" "-Q") "Quiet the program" (set! quiet-program? #t)] + [("--place") + "Run tests in places instead of processes" + (set! default-mode 'place)] + [("--jobs" "-j") n + "Run up to tests in parallel" + (set-jobs! (string->number* "jobs" n exact-positive-integer?))] + [("--timeout") seconds + "Set default timeout to " + (set-jobs! (string->number* "timeout" seconds real?))] #:once-any [("--collection" "-c") "Interpret arguments as collections" @@ -243,7 +520,19 @@ "Interpret arguments as packages" (set! packages? #t)] #:args file-or-directory - (begin (define sum (map do-test-wrap file-or-directory)) + (begin (define sum + ;; The #:sema argument everywhre makes tests start + ;; in a deterministic order: + (map/parallel test-top file-or-directory + #:sema (make-semaphore))) (when table? (display-summary sum)) + ;; Re-log failures and successes, and then report using `test-log`. + ;; (This is awkward; is it better to not try to use `test-log`?) + (for ([s (in-list sum)]) + (for ([i (in-range (summary-failed s))]) + (test-log! #f)) + (for ([i (in-range (- (summary-total s) + (summary-failed s)))]) + (test-log! #t))) (void (test-log #:display? #t #:exit? #t)))) From 48f4bed9aab2ea1215479a0b485d357629bbfb9f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Dec 2013 06:04:34 -0600 Subject: [PATCH 349/466] raco test: default mode more like before By default, a single file runs directly, instead of in a subprocess, and stderr is not checked. That's both more in line with the old behavior and more suitable for DrDr's use in running an individual test. Also, get rid of the `drdr` submodule, which doesn't look like a good idea anymore. original commit: 3b3c3726ba03fa90fc1c0010e1adc0dc760b4fb3 --- .../compiler-lib/compiler/commands/test.rkt | 153 +++++++++++++----- 1 file changed, 113 insertions(+), 40 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 8564b55810..a8f8310400 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -8,27 +8,49 @@ racket/path racket/place racket/future + racket/file compiler/find-exe raco/command-name racket/system rackunit/log pkg/lib) -(define submodules '()) +(define submodules '()) ; '() means "default" (define first-avail? #f) (define run-anyways? #t) (define quiet? #f) (define quiet-program? #f) +(define check-stderr? #f) (define table? #f) -(define jobs 0) +(define jobs 0) ; 0 mean "default" (define task-sema (make-semaphore 1)) -(define default-timeout +inf.0) -(define default-mode 'process) +(define default-timeout #f) ; #f means "none" +(define default-mode #f) ; #f => depends on how many files are provided -;; Stub for running a test in a place: -(module start racket/base +(define single-file? #t) + +;; Stub for running a test in a process: +(module process racket/base + (require rackunit/log) + ;; Arguments are a temp file to hold test results, the module + ;; path to run, and the `dynamic-require` second argument: + (define argv (current-command-line-arguments)) + (define result-file (vector-ref argv 0)) + (define test-module (read (open-input-string (vector-ref argv 1)))) + (define d (read (open-input-string (vector-ref argv 2)))) + + (dynamic-require test-module d) + + (call-with-output-file* + result-file + #:exists 'truncate + (lambda (o) + (write (test-log #:display? #f #:exit? #f) o)))) + +;; Driver for running a test in a place: +(module place racket/base (require racket/place rackunit/log) (provide go) @@ -54,7 +76,10 @@ ;; Run each test in its own place or process, and collect both test ;; results and whether any output went to stderr. (define (dynamic-require-elsewhere p d - #:mode [mode default-mode] + #:mode [mode (or default-mode + (if single-file? + 'direct + 'process))] #:timeout [timeout default-timeout]) (define c (make-custodian)) (with-handlers ([exn:fail? (lambda (exn) @@ -71,15 +96,36 @@ (current-output-port))) (define stderr (if quiet-program? e - (tee-output-port (current-error-port) e))) + (if check-stderr? + (tee-output-port (current-error-port) e) + (current-error-port)))) (define-values (result-code test-results) (case mode + [(direct) + (define pre (test-log #:display? #f #:exit? #f)) + (define done? #f) + (define t + (parameterize ([current-output-port stdout] + [current-error-port stderr] + [current-command-line-arguments '#()]) + (thread + (lambda () + (dynamic-require p d) + (set! done? #t))))) + (unless (thread? (sync/timeout timeout t)) + (error 'test "timeout after ~a seconds" timeout)) + (unless done? + (error 'test "test raised an exception")) + (define post (test-log #:display? #f #:exit? #f)) + (values 0 + (cons (- (car post) (car pre)) + (- (cdr post) (cdr pre))))] [(place) ;; Start the test place: (define-values (pl in out/f err/f) (parameterize ([current-custodian c]) - (dynamic-place* '(submod compiler/commands/test start) + (dynamic-place* '(submod compiler/commands/test place) 'go #:in (current-input-port) #:out stdout @@ -96,6 +142,7 @@ (values (place-wait pl) (sync/timeout 0 pl))] [(process) + (define tmp-file (make-temporary-file)) (define ps (parameterize ([current-output-port stdout] [current-error-port stderr] @@ -108,23 +155,32 @@ "-l" "racket/base" "-e" - (format "(dynamic-require '~s ~s)" - (normalize-module-path p) - d)))) + "(dynamic-require '(submod compiler/commands/test process) #f)" + tmp-file + (format "~s" (normalize-module-path p)) + (format "~s" d)))) (define proc (list-ref ps 4)) (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) (error 'test "timeout after ~a seconds" timeout)) + + (define results + (with-handlers ([exn:fail:read? (lambda () #f)]) + (call-with-input-file* tmp-file read))) (values (proc 'exit-code) - #f)])) + (and (pair? results) + (exact-positive-integer? (car results)) + (exact-positive-integer? (cdr results)) + results))])) ;; Shut down the place/process (usually a no-op unless it timed out): (custodian-shutdown-all c) ;; Check results: - (unless (equal? #"" (get-output-bytes e)) - (error 'test "non-empty stderr: ~e" (get-output-bytes e))) + (when check-stderr? + (unless (equal? #"" (get-output-bytes e)) + (error 'test "non-empty stderr: ~e" (get-output-bytes e)))) (unless (zero? result-code) (error 'test "non-zero exit: ~e" result-code)) (cond @@ -177,8 +233,9 @@ (lambda (what get-default) (get-default)))) (dynamic-require-elsewhere p d - #:timeout (lookup 'timeout - (lambda () default-timeout)))) + #:timeout (or (lookup 'timeout + (lambda () default-timeout)) + +inf.0))) (define current-label (make-parameter "???")) (struct summary (failed total label body-res)) @@ -329,6 +386,7 @@ [(? path? p) (cond [(directory-exists? p) + (set! single-file? #f) (with-summary `(directory ,p) (map/parallel @@ -466,18 +524,26 @@ (command-line #:program (short-program+command-name) + #:once-any + [("--collection" "-c") + "Interpret arguments as collections" + (set! collections? #t)] + [("--package" "-p") + "Interpret arguments as packages" + (set! packages? #t)] #:once-each [("--drdr") "Configure defaults to imitate DrDr" - (when (null? submodules) - (set! submodules '(drdr test))) (set! first-avail? #t) (when (zero? jobs) (set-jobs! (processor-count))) - (when (equal? default-timeout +inf.0) + (unless default-timeout (set! default-timeout 600)) + (set! check-stderr? #t) (set! quiet-program? #t) - (set! table? #t)] + (set! table? #t) + (unless default-mode + (set! default-mode 'process))] #:multi [("--submodule" "-s") name "Runs submodule \n (defaults to running just the `test' submodule)" @@ -494,33 +560,39 @@ [("--first-avail") "Run only the first available submodule" (set! first-avail? #f)] - [("--quiet" "-q") - "Suppress `raco test: ...' message" - (set! quiet? #t)] - [("--table" "-t") - "Print a summary table" - (set! table? #t)] - [("--quiet-program" "-Q") - "Quiet the program" - (set! quiet-program? #t)] + #:once-any + [("--direct") + "Run tests directly (default for a single file)" + (set! default-mode 'direct)] + [("--process") + "Run tests in separate processes (default for multiple files)" + (set! default-mode 'process)] [("--place") - "Run tests in places instead of processes" + "Run tests in places" (set! default-mode 'place)] + #:once-each [("--jobs" "-j") n "Run up to tests in parallel" (set-jobs! (string->number* "jobs" n exact-positive-integer?))] [("--timeout") seconds "Set default timeout to " (set-jobs! (string->number* "timeout" seconds real?))] - #:once-any - [("--collection" "-c") - "Interpret arguments as collections" - (set! collections? #t)] - [("--package" "-p") - "Interpret arguments as packages" - (set! packages? #t)] + [("--quiet-program" "-Q") + "Quiet the program" + (set! quiet-program? #t)] + [("--check-stderr" "-e") + "Treat stderr output as a test failure" + (set! check-stderr? #t)] + [("--quiet" "-q") + "Suppress `raco test: ...' message" + (set! quiet? #t)] + [("--table" "-t") + "Print a summary table" + (set! table? #t)] #:args file-or-directory - (begin (define sum + (begin (unless (= 1 (length file-or-directory)) + (set! single-file? #f)) + (define sum ;; The #:sema argument everywhre makes tests start ;; in a deterministic order: (map/parallel test-top file-or-directory @@ -535,4 +607,5 @@ (for ([i (in-range (- (summary-total s) (summary-failed s)))]) (test-log! #t))) - (void (test-log #:display? #t #:exit? #t)))) + (define r (test-log #:display? #t #:exit? #t)) + (exit (if (zero? (car r)) 0 1)))) From 11c41cb89b39181217225aeba652e8f9633fbfec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Dec 2013 08:35:21 -0600 Subject: [PATCH 350/466] raco test: add "info.rkt" field `test-omit-paths` Using an "info.rkt" field is a fallback for when a submodule won't do (e.g., because the module doesn't normally compile). original commit: 81a03d59de401403c56c23a506a63d26b1904a11 --- .../compiler-lib/compiler/commands/test.rkt | 99 ++++++++++++++++--- 1 file changed, 88 insertions(+), 11 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index a8f8310400..d71ae4e250 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -13,7 +13,9 @@ raco/command-name racket/system rackunit/log - pkg/lib) + pkg/lib + setup/collects + setup/getinfo) (define submodules '()) ; '() means "default" (define first-avail? #f) @@ -379,24 +381,33 @@ (set! ids (cons id ids)))))))) ;; Perform all tests in path `e`: -(define (test-files e [check-suffix? #f] #:sema continue-sema) +(define (test-files e + #:check-suffix? [check-suffix? #f] + #:sema continue-sema) (match e [(? string? s) - (test-files (string->path s) check-suffix? #:sema continue-sema)] + (test-files (string->path s) + #:check-suffix? check-suffix? + #:sema continue-sema)] [(? path? p) (cond [(directory-exists? p) (set! single-file? #f) - (with-summary - `(directory ,p) - (map/parallel - (λ (dp #:sema s) - (test-files (build-path p dp) #t #:sema s)) - (directory-list p) - #:sema continue-sema))] + (if (omit-path? (path->directory-path p)) + (summary 0 0 #f 0) + (with-summary + `(directory ,p) + (map/parallel + (λ (dp #:sema s) + (test-files (build-path p dp) + #:check-suffix? #t + #:sema s)) + (directory-list p) + #:sema continue-sema)))] [(and (file-exists? p) (or (not check-suffix?) - (regexp-match #rx#"\\.rkt$" (path->bytes p)))) + (regexp-match #rx#"\\.rkt$" (path->bytes p))) + (not (omit-path? p))) (parameterize ([current-directory (let-values ([(base name dir?) (split-path p)]) (if (path? base) base @@ -513,6 +524,72 @@ [else (test-files e #:sema continue-sema)])) +;; -------------------------------------------------- +;; Reading "info.rkt" files + +(define omit-paths (make-hash)) + +(define collects-cache (make-hash)) +(define info-done (make-hash)) + +(define (check-info p check-up?) + (define-values (base name dir?) (split-path p)) + (define dir (normalize-info-path + (if dir? + p + (if (path? base) + (path->complete-path base) + (current-directory))))) + + (when (and check-up? (not dir?)) + ;; Check enclosing collection + (define c (path->collects-relative p #:cache collects-cache)) + (when (list? c) + (check-info/parents dir + (apply build-path (map bytes->path (reverse (cdr (reverse (cdr c))))))))) + + (unless (hash-ref info-done dir #f) + (hash-set! info-done dir #t) + (define info (get-info/full dir)) + (when info + (define v (info 'test-omit-paths (lambda () '()))) + (define (bad) + (log-error "bad `test-omit-paths` in \"info.rkt\": ~e" v)) + (cond + [(eq? v 'all) + (hash-set! omit-paths dir #t)] + [(list? v) + (for ([i (in-list v)]) + (unless (path-string? i) (bad)) + (define p (normalize-info-path (path->complete-path i dir))) + (define dp (if (directory-exists? p) + (path->directory-path p) + p)) + (hash-set! omit-paths dp #t))] + [else (bad)])))) + +(define (check-info/parents dir subpath) + (let loop ([dir dir] [subpath subpath]) + (unless (hash-ref info-done dir #f) + (check-info dir #f) + (define-values (next-subpath subpath-name subpath-dir?) (split-path subpath)) + (define-values (next-dir dir-name dir-dir?) (split-path dir)) + (when (path? next-subpath) + (loop next-dir next-subpath))))) + +(define (normalize-info-path p) + (simplify-path (path->complete-path p) #f)) + +(define (omit-path? p) + (check-info p #t) + (let ([p (normalize-info-path p)]) + (or (hash-ref omit-paths p #f) + (let-values ([(base name dir?) (split-path p)]) + (and (path? base) + (omit-path? base)))))) + +;; -------------------------------------------------- + (define (string->number* what s check) (define n (string->number s)) (unless (check n) From 7ff04c1dfabd06f8d72aca322f851acebf5e2b58 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Dec 2013 09:38:01 -0600 Subject: [PATCH 351/466] raco test: fix process command-line handling and adjust timeout handling original commit: bbb0c5f6e909ab36e85882dd76be8f3274a1c2ef --- .../compiler-pkgs/compiler-lib/compiler/commands/test.rkt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index d71ae4e250..a71d110e52 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -43,7 +43,8 @@ (define test-module (read (open-input-string (vector-ref argv 1)))) (define d (read (open-input-string (vector-ref argv 2)))) - (dynamic-require test-module d) + (parameterize ([current-command-line-arguments '#()]) + (dynamic-require test-module d)) (call-with-output-file* result-file @@ -235,7 +236,8 @@ (lambda (what get-default) (get-default)))) (dynamic-require-elsewhere p d - #:timeout (or (lookup 'timeout + #:timeout (if default-timeout + (lookup 'timeout (lambda () default-timeout)) +inf.0))) @@ -653,7 +655,7 @@ (set-jobs! (string->number* "jobs" n exact-positive-integer?))] [("--timeout") seconds "Set default timeout to " - (set-jobs! (string->number* "timeout" seconds real?))] + (set! default-timeout (string->number* "timeout" seconds real?))] [("--quiet-program" "-Q") "Quiet the program" (set! quiet-program? #t)] From 65ece182a782ad57ccda327f0ba5e8b6024d7bb7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Dec 2013 13:14:22 -0600 Subject: [PATCH 352/466] raco test: add `test-command-line-arguments` field for "info.rkt" Also, make `--drdr` timeout 90 seconds instead of 600. original commit: f830768c375f8387b9573eb549f90d0a0da8d0f3 --- .../compiler-lib/compiler/commands/test.rkt | 84 ++++++++++++------- 1 file changed, 55 insertions(+), 29 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index a71d110e52..e5b7cafe98 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -42,8 +42,9 @@ (define result-file (vector-ref argv 0)) (define test-module (read (open-input-string (vector-ref argv 1)))) (define d (read (open-input-string (vector-ref argv 2)))) + (define args (list-tail (vector->list argv) 3)) - (parameterize ([current-command-line-arguments '#()]) + (parameterize ([current-command-line-arguments (list->vector args)]) (dynamic-require test-module d)) (call-with-output-file* @@ -60,7 +61,8 @@ (define (go pch) (define l (place-channel-get pch)) ;; Run the test: - (parameterize ([current-command-line-arguments '#()] + (parameterize ([current-command-line-arguments (list->vector + (cadddr l))] [current-directory (caddr l)]) (dynamic-require (car l) (cadr l))) ;; If the tests use `rackunit`, collect result stats: @@ -78,7 +80,7 @@ ;; Run each test in its own place or process, and collect both test ;; results and whether any output went to stderr. -(define (dynamic-require-elsewhere p d +(define (dynamic-require-elsewhere p d args #:mode [mode (or default-mode (if single-file? 'direct @@ -111,7 +113,7 @@ (define t (parameterize ([current-output-port stdout] [current-error-port stderr] - [current-command-line-arguments '#()]) + [current-command-line-arguments (list->vector args)]) (thread (lambda () (dynamic-require p d) @@ -135,7 +137,7 @@ #:err stderr))) ;; Send the module path to test: - (place-channel-put pl (list p d (current-directory))) + (place-channel-put pl (list p d (current-directory) args)) ;; Wait for the place to finish: (unless (sync/timeout timeout (place-dead-evt pl)) @@ -151,17 +153,19 @@ [current-error-port stderr] [current-subprocess-custodian-mode 'kill] [current-custodian c]) - (process*/ports stdout - (current-input-port) - stderr - (find-exe) - "-l" - "racket/base" - "-e" - "(dynamic-require '(submod compiler/commands/test process) #f)" - tmp-file - (format "~s" (normalize-module-path p)) - (format "~s" d)))) + (apply process*/ports + stdout + (current-input-port) + stderr + (find-exe) + "-l" + "racket/base" + "-e" + "(dynamic-require '(submod compiler/commands/test process) #f)" + tmp-file + (format "~s" (normalize-module-path p)) + (format "~s" d) + args))) (define proc (list-ref ps 4)) (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) @@ -226,7 +230,7 @@ (append mod '(config)) (error 'test "cannot add test-config submodule to path: ~s" mod))) -(define (dynamic-require* p d try-config?) +(define (dynamic-require* p d args try-config?) (define lookup (or (cond [(not try-config?) #f] @@ -235,7 +239,7 @@ [else #f]) (lambda (what get-default) (get-default)))) (dynamic-require-elsewhere - p d + p d args #:timeout (if default-timeout (lookup 'timeout (lambda () default-timeout)) @@ -353,7 +357,7 @@ ;; Perform test of one module (in parallel, as allowed by ;; `task-sema`): -(define (test-module p mod try-config? #:sema continue-sema) +(define (test-module p mod args try-config? #:sema continue-sema) (call-with-semaphore task-sema ; limits parallelism (lambda () @@ -366,17 +370,20 @@ (set! ids (cdr ids)) (unless quiet? ;; in lock, so printouts are not interleaved - (printf "raco test: ~a~s\n" + (printf "raco test: ~a~s~a\n" (if (jobs . <= . 1) "" (format "~a " id)) (let ([m (normalize-module-path p)]) (if (and (pair? mod) (eq? 'submod (car mod))) (list* 'submod m (cddr mod)) - m)))) + m)) + (apply string-append + (for/list ([a (in-list args)]) + (format " ~s" (format "~a" a)))))) id))) (begin0 - (dynamic-require* mod 0 try-config?) + (dynamic-require* mod 0 args try-config?) (call-with-semaphore ids-lock (lambda () @@ -410,6 +417,7 @@ (or (not check-suffix?) (regexp-match #rx#"\\.rkt$" (path->bytes p))) (not (omit-path? p))) + (define args (get-cmdline p)) (parameterize ([current-directory (let-values ([(base name dir?) (split-path p)]) (if (path? base) base @@ -431,13 +439,13 @@ #f] [(module-declared? mod #t) (set! did-one? #t) - (test-module p mod #t #:sema continue-sema)] + (test-module p mod args #t #:sema continue-sema)] [else (set! something-wasnt-declared? #t) #f])) (list (and (and run-anyways? something-wasnt-declared?) - (test-module p file-name #f #:sema continue-sema))))))))] + (test-module p file-name args #f #:sema continue-sema))))))))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)] [else (summary 0 0 #f null)])])) @@ -530,6 +538,7 @@ ;; Reading "info.rkt" files (define omit-paths (make-hash)) +(define command-line-arguments (make-hash)) (define collects-cache (make-hash)) (define info-done (make-hash)) @@ -555,20 +564,33 @@ (define info (get-info/full dir)) (when info (define v (info 'test-omit-paths (lambda () '()))) - (define (bad) - (log-error "bad `test-omit-paths` in \"info.rkt\": ~e" v)) + (define (bad what v) + (log-error "bad `~a' in \"info.rkt\": ~e" what v)) (cond [(eq? v 'all) (hash-set! omit-paths dir #t)] [(list? v) (for ([i (in-list v)]) - (unless (path-string? i) (bad)) + (unless (path-string? i) (bad 'test-omit-paths v)) (define p (normalize-info-path (path->complete-path i dir))) (define dp (if (directory-exists? p) (path->directory-path p) p)) (hash-set! omit-paths dp #t))] - [else (bad)])))) + [else (bad 'test-omit-paths v)]) + + (define a (info 'test-command-line-arguments (lambda () '()))) + (unless (list? a) (bad 'test-command-line-arguments a)) + (for ([arg (in-list a)]) + (unless (and (list? arg) + (= 2 (length arg)) + (path-string? (car arg)) + (list? (cadr arg)) + (andmap path-string? (cadr arg))) + (bad 'test-command-line-arguments a)) + (hash-set! command-line-arguments + (normalize-info-path (path->complete-path (car arg) dir)) + (cadr arg)))))) (define (check-info/parents dir subpath) (let loop ([dir dir] [subpath subpath]) @@ -590,6 +612,10 @@ (and (path? base) (omit-path? base)))))) +(define (get-cmdline p) + (let ([p (normalize-info-path p)]) + (hash-ref command-line-arguments p null))) + ;; -------------------------------------------------- (define (string->number* what s check) @@ -617,7 +643,7 @@ (when (zero? jobs) (set-jobs! (processor-count))) (unless default-timeout - (set! default-timeout 600)) + (set! default-timeout 90)) (set! check-stderr? #t) (set! quiet-program? #t) (set! table? #t) From ba1038998fd67f6e0ee5a70e02782cd71c7a9fe5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Dec 2013 19:05:35 -0600 Subject: [PATCH 353/466] raco test: use `executable-yield-handler` before exit original commit: 4a19403288202c934df7208c7fe0decee0a2365d --- .../compiler-lib/compiler/commands/test.rkt | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index e5b7cafe98..bdd7330db6 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -45,13 +45,15 @@ (define args (list-tail (vector->list argv) 3)) (parameterize ([current-command-line-arguments (list->vector args)]) - (dynamic-require test-module d)) + (dynamic-require test-module d) + ((executable-yield-handler) 0)) (call-with-output-file* result-file #:exists 'truncate (lambda (o) - (write (test-log #:display? #f #:exit? #f) o)))) + (write (test-log #:display? #f #:exit? #f) o))) + (exit 0)) ;; Driver for running a test in a place: (module place racket/base @@ -64,7 +66,8 @@ (parameterize ([current-command-line-arguments (list->vector (cadddr l))] [current-directory (caddr l)]) - (dynamic-require (car l) (cadr l))) + (dynamic-require (car l) (cadr l)) + ((executable-yield-handler) 0)) ;; If the tests use `rackunit`, collect result stats: (define test-results (test-log #:display? #f #:exit? #f)) @@ -117,6 +120,7 @@ (thread (lambda () (dynamic-require p d) + ((executable-yield-handler) 0) (set! done? #t))))) (unless (thread? (sync/timeout timeout t)) (error 'test "timeout after ~a seconds" timeout)) From 74702c1f942df909b6b5da15a3064df8893c8bec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Dec 2013 10:29:19 -0600 Subject: [PATCH 354/466] move "props" test configs to `test` submodules or "info.rkt" files The "props" file still has * ".rkt" `drdr:timeout` entries, needed until DrDr uses submodules and "info.rkt" files; although timeout information has been put in submodules for `raco test`, DrDr uses `raco test` in a way that does not enable timeouts, so that DrDr can implement timeouts itself (and record when a test times out) * ".rkt" `drdr:random #t` entries; not sure what to do with these, yet * ".rkt" `responsible` entries; not sure what to do with these, yet * ".rktl" `drdr:command-line #f` entries, needed until all ".rktl" files are disabled in DrDr The following files were previously disabled for DrDr testing, but were intentionally left as enabled with these changes: pkgs/racket-pkgs/racket-test/tests/pkg/shelly.rkt pkgs/racket-pkgs/racket-test/tests/pkg/util.rkt pkgs/racket-pkgs/racket-test/tests/pkg/info.rkt pkgs/racket-pkgs/racket-test/tests/pkg/basic-index.rkt pkgs/racket-pkgs/racket-test/tests/racket/link.rkt pkgs/racket-pkgs/racket-test/tests/racket/embed-in-c.rkt pkgs/racket-pkgs/racket-doc/ffi/examples/use-c-printf.rkt pkgs/racket-pkgs/racket-doc/ffi/examples/c-printf.rkt pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/error-tests.rkt pkgs/mysterx/mysterx.rkt pkgs/mysterx/main.rkt pkgs/games/gobblet/test-model.rkt pkgs/games/gobblet/test-explore.rkt pkgs/games/gobblet/robot.rkt pkgs/games/gobblet/check.rkt pkgs/db-pkgs/db-lib/db/private/odbc/main.rkt pkgs/db-pkgs/db-lib/db/private/odbc/ffi.rkt pkgs/db-pkgs/db-lib/db/private/odbc/dbsystem.rkt pkgs/db-pkgs/db-lib/db/private/odbc/connection.rkt pkgs/distributed-places-pkgs/distributed-places-lib/racket/place/distributed/examples/hello-world.rkt pkgs/redex-pkgs/redex-lib/redex/private/compiler/match.rkt pkgs/redex-pkgs/redex-lib/redex/private/compiler/match.rkt pkgs/htdp-pkgs/htdp-test/2htdp/utest/balls.rkt pkgs/gui-pkgs/gui-test/framework/tests/test-suite-utils.rkt pkgs/games/paint-by-numbers/raw-problems/size-calculation.rkt pkgs/db-pkgs/db-lib/db/odbc.rkt pkgs/compatibility-pkgs/compatibility-lib/mzlib/traceld.rkt pkgs/cext-lib/dynext/private/stdio.rkt pkgs/db-pkgs/db-lib/db/odbc.rkt racket/collects/ffi/unsafe/objc.rkt racket/collects/ffi/objc.rkt pkgs/racket-pkgs/racket-test/tests/pkg/tests-db.rkt pkgs/racket-pkgs/racket-test/tests/pkg/test-docs.rkt pkgs/racket-pkgs/racket-test/tests/pkg/test-catalogs-api.rkt pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/main.rkt pkgs/redex-pkgs/redex-lib/redex/private/compiler/redextomatrix.rkt pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt pkgs/planet-pkgs/planet-test/tests/planet/version.rkt pkgs/planet-pkgs/planet-test/tests/planet/test-docs-complete.rkt pkgs/planet-pkgs/planet-test/tests/planet/lang.rkt pkgs/planet-pkgs/planet-test/tests/planet/docs-build.rkt pkgs/drracket-pkgs/drracket-test/tests/drracket/follow-log.rkt pkgs/drracket-pkgs/drracket/drracket/private/dock-icon.rkt pkgs/drracket-pkgs/drracket-test/tests/drracket/tool-lib-and-sig.rkt original commit: e226ad66c5fb6095d5702e5c47f5c7cf73e914f5 --- .../compiler-lib/compiler/commands/exe-dir.rkt | 2 ++ pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt | 2 ++ pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt | 2 ++ pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt | 1 + .../compiler-lib/compiler/demodularizer/batch.rkt | 2 ++ .../compiler-test/tests/compiler/embed/embed-me9.rkt | 5 ++++- .../compiler-test/tests/compiler/embed/info.rkt | 4 ++++ .../compiler-test/tests/compiler/zo-test-worker.rkt | 2 ++ pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt | 6 ++++++ 9 files changed, 25 insertions(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt index dae09d1438..acc3b94919 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt @@ -29,3 +29,5 @@ #:copy-collects (exe-dir-add-collects-dirs)) (when (verbose) (printf " [output to \"~a\"]\n" dest-dir)) + +(module test racket/base) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt index e1241b11f1..305879651f 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt @@ -140,3 +140,5 @@ (exe-aux)))]) (when (verbose) (printf " [output to \"~a\"]\n" dest))) + +(module test racket/base) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt index b998b0e7c8..74fd5ff6ce 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt @@ -7,6 +7,8 @@ setup/parallel-build racket/match) +(module test racket/base) + (define verbose (make-parameter #f)) (define very-verbose (make-parameter #f)) (define disable-inlining (make-parameter #f)) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt index eba5bf0865..ebb56ae73a 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt @@ -96,3 +96,4 @@ (when (verbose) (printf " [output to \"~a\"]\n" plt-output)))) +(module test racket/base) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt index 6ec08d76ec..456ded38e7 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt @@ -57,3 +57,5 @@ Here's the idea: (garbage-collect-toplevels-enabled #t)] #:args (filename) (demodularize filename (output-file)))) + +(module test racket/base) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt index 877eed97de..cdb4847278 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt @@ -3,4 +3,7 @@ (with-output-to-file "stdout" (lambda () (printf "~a\n" (ex))) - 'append)) + 'append) + + (module test racket/base)) + diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt index 7882f9f179..538a0e0b38 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt @@ -12,3 +12,7 @@ "embed-isl.rkt" "embed-isll.rkt" "embed-asl.rkt")) + +(define test-omit-paths '("embed-me9.rkt" + "embed-planet-1" + "embed-planet-2")) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt index e46284548d..8be85d8121 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt @@ -268,3 +268,5 @@ (command-line #:program "zo-test-worker" #:args (file) (run-test file)) + +(module test racket/base) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt index 20158c5404..6bd475bbaa 100755 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt @@ -227,3 +227,9 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (printf "~a:\n~a\n\n" (car p) (cdr p))))))))) (thread-wait final-thread) + +;; Test mode: +(module test racket/base + (require syntax/location) + (parameterize ([current-command-line-arguments (vector "-I" "-S" "-t" "60" "-v" "-R")]) + (dynamic-require (quote-module-path "..") #f))) From 51e419cfc255e4221debab3ab26857d0483c13f8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Dec 2013 09:30:48 -0700 Subject: [PATCH 355/466] raco test: run ".scrbl" files by default; check cmdline args for all files To test a file that ends in".ss", ".scm", etc., add a `test-command-line-arguments` entry to an "info.rkt" file. original commit: e44b15c032f19af08f2080be62eec1a8459858af --- .../compiler-lib/compiler/commands/test.rkt | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index bdd7330db6..d50a71f8d0 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -17,6 +17,10 @@ setup/collects setup/getinfo) +(define rx:default-suffixes #rx#"\\.(?:rkt|scrbl)$") +;; For any other file suffix, a `test-command-line-arguments` +;; entry is required in "info.rkt". + (define submodules '()) ; '() means "default" (define first-avail? #f) (define run-anyways? #t) @@ -384,7 +388,8 @@ m)) (apply string-append (for/list ([a (in-list args)]) - (format " ~s" (format "~a" a)))))) + (format " ~s" (format "~a" a))))) + (flush-output)) id))) (begin0 (dynamic-require* mod 0 args try-config?) @@ -419,7 +424,8 @@ #:sema continue-sema)))] [(and (file-exists? p) (or (not check-suffix?) - (regexp-match #rx#"\\.rkt$" (path->bytes p))) + (regexp-match rx:default-suffixes p) + (get-cmdline p #f)) (not (omit-path? p))) (define args (get-cmdline p)) (parameterize ([current-directory (let-values ([(base name dir?) (split-path p)]) @@ -616,9 +622,9 @@ (and (path? base) (omit-path? base)))))) -(define (get-cmdline p) +(define (get-cmdline p [default null]) (let ([p (normalize-info-path p)]) - (hash-ref command-line-arguments p null))) + (hash-ref command-line-arguments p default))) ;; -------------------------------------------------- From b29b18178b40eb0a362183d44217b358845923c1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Dec 2013 09:48:59 -0700 Subject: [PATCH 356/466] raco test: fix error summary in direct mode Also, fix a doc typo original commit: 58d425c00ca70a5eed9cc86f5215de3b2754a2f5 --- .../compiler-lib/compiler/commands/test.rkt | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index d50a71f8d0..064aa735fe 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -714,13 +714,15 @@ #:sema (make-semaphore))) (when table? (display-summary sum)) - ;; Re-log failures and successes, and then report using `test-log`. - ;; (This is awkward; is it better to not try to use `test-log`?) - (for ([s (in-list sum)]) - (for ([i (in-range (summary-failed s))]) - (test-log! #f)) - (for ([i (in-range (- (summary-total s) - (summary-failed s)))]) - (test-log! #t))) + (unless (or (eq? default-mode 'direct) + (and (not default-mode) single-file?)) + ;; Re-log failures and successes, and then report using `test-log`. + ;; (This is awkward; is it better to not try to use `test-log`?) + (for ([s (in-list sum)]) + (for ([i (in-range (summary-failed s))]) + (test-log! #f)) + (for ([i (in-range (- (summary-total s) + (summary-failed s)))]) + (test-log! #t)))) (define r (test-log #:display? #t #:exit? #t)) (exit (if (zero? (car r)) 0 1)))) From 8453e447989fc1fa6e6ce76b0f680c3d363861a2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Dec 2013 17:03:11 -0700 Subject: [PATCH 357/466] raco test: add -m/--modules flag, exit code 2 for timeout Treats file arguments the same as a file in a directory, package, or collection. If any test fails due to a timeout, the exit code is 2 (instead of 1 for only non-timeout failures or 0 for only success). original commit: bce27aa387c24789077e91a66f9b780addb4379e --- .../compiler-lib/compiler/commands/test.rkt | 53 +++++++++++++------ 1 file changed, 38 insertions(+), 15 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 064aa735fe..4388007656 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -94,13 +94,14 @@ 'process))] #:timeout [timeout default-timeout]) (define c (make-custodian)) + (define timeout? #f) (with-handlers ([exn:fail? (lambda (exn) (custodian-shutdown-all c) (unless quiet? (eprintf "~a: ~a\n" (extract-file-name p) (exn-message exn))) - (summary 1 1 (current-label) #f))]) + (summary 1 1 (current-label) #f (if timeout? 1 0)))]) (define e (open-output-bytes)) (define stdout (if quiet-program? @@ -127,6 +128,7 @@ ((executable-yield-handler) 0) (set! done? #t))))) (unless (thread? (sync/timeout timeout t)) + (set! timeout? #t) (error 'test "timeout after ~a seconds" timeout)) (unless done? (error 'test "test raised an exception")) @@ -149,6 +151,7 @@ ;; Wait for the place to finish: (unless (sync/timeout timeout (place-dead-evt pl)) + (set! timeout? #t) (error 'test "timeout after ~a seconds" timeout)) ;; Get result code and test results: @@ -177,6 +180,7 @@ (define proc (list-ref ps 4)) (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) + (set! timeout? #t) (error 'test "timeout after ~a seconds" timeout)) (define results @@ -200,9 +204,9 @@ (error 'test "non-zero exit: ~e" result-code)) (cond [test-results - (summary (car test-results) (cdr test-results) (current-label) #f)] + (summary (car test-results) (cdr test-results) (current-label) #f 0)] [else - (summary 0 1 (current-label) #f)]))) + (summary 0 1 (current-label) #f 0)]))) ;; For recording stderr while also propagating to the original stderr: (define (tee-output-port p1 p2) @@ -254,7 +258,7 @@ +inf.0))) (define current-label (make-parameter "???")) -(struct summary (failed total label body-res)) +(struct summary (failed total label body-res timeout)) (define-syntax-rule (with-summary label . body) (call-with-summary label (lambda () . body))) @@ -270,7 +274,8 @@ (apply + (map summary-failed res)) (apply + (map summary-total res)) (current-label) - res))) + res + (apply + (map summary-timeout res))))) (define (iprintf i fmt . more) @@ -283,9 +288,9 @@ (match sum [(list sum ...) (append-map flatten sum)] - [(summary failed total `(file ,p) body) + [(summary failed total `(file ,p) body timeout) (list sum)] - [(summary failed total label body) + [(summary failed total label body timeout) (flatten body)] [(? void?) empty]))) @@ -304,7 +309,7 @@ (define failed-wid (max-width summary-failed)) (define total-wid (max-width summary-total)) (for ([f (in-list sfiles)]) - (match-define (summary failed total `(file ,p) _) f) + (match-define (summary failed total `(file ,p) _ _) f) (displayln (~a (~a #:min-width failed-wid #:align 'right (if (zero? failed) @@ -412,7 +417,7 @@ [(directory-exists? p) (set! single-file? #f) (if (omit-path? (path->directory-path p)) - (summary 0 0 #f 0) + (summary 0 0 #f null 0) (with-summary `(directory ,p) (map/parallel @@ -458,7 +463,7 @@ (test-module p file-name args #f #:sema continue-sema))))))))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)] - [else (summary 0 0 #f null)])])) + [else (summary 0 0 #f null 0)])])) (module paths racket/base (require setup/link @@ -523,8 +528,11 @@ (define collections? #f) (define packages? #f) +(define check-top-suffix? #f) -(define (test-top e #:sema continue-sema) +(define (test-top e + #:check-suffix? check-suffix? + #:sema continue-sema) (cond [collections? (match (collection-paths e) @@ -542,7 +550,9 @@ (test-files pd #:sema continue-sema)) (error 'test "Package ~e is not installed" e))] [else - (test-files e #:sema continue-sema)])) + (test-files e + #:check-suffix? check-suffix? + #:sema continue-sema)])) ;; -------------------------------------------------- ;; Reading "info.rkt" files @@ -646,9 +656,14 @@ [("--package" "-p") "Interpret arguments as packages" (set! packages? #t)] + [("--modules" "-m") + ("Interpret arguments as modules" + " (ignore argument unless \".rkt\", \".scrbl\", or enabled by \"info.rkt\")") + (set! check-top-suffix? #t)] #:once-each [("--drdr") "Configure defaults to imitate DrDr" + (set! check-top-suffix? #t) (set! first-avail? #t) (when (zero? jobs) (set-jobs! (processor-count))) @@ -710,7 +725,11 @@ (define sum ;; The #:sema argument everywhre makes tests start ;; in a deterministic order: - (map/parallel test-top file-or-directory + (map/parallel (lambda (f #:sema s) + (test-top f + #:check-suffix? check-top-suffix? + #:sema s)) + file-or-directory #:sema (make-semaphore))) (when table? (display-summary sum)) @@ -724,5 +743,9 @@ (for ([i (in-range (- (summary-total s) (summary-failed s)))]) (test-log! #t)))) - (define r (test-log #:display? #t #:exit? #t)) - (exit (if (zero? (car r)) 0 1)))) + (test-log #:display? #t #:exit? #f) + (define sum1 (call-with-summary #f (lambda () sum))) + (exit (cond + [(positive? (summary-timeout sum1)) 2] + [(positive? (summary-failed sum1)) 1] + [else 0])))) From 16509fa8e832d11dc103befb2ce8f7f4a6139db7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 31 Dec 2013 14:52:07 -0700 Subject: [PATCH 358/466] raco test: responsible-party and varying-party logging, lock names The responsible party for a test defaults to the enclosing package's author. Also, add support for a `test-timeouts` fallback in "info.rkt". original commit: 59cbefe47aaeb3d9407c12b63f6c9541354205a6 --- .../compiler-lib/compiler/commands/test.rkt | 452 ++++++++++++------ 1 file changed, 300 insertions(+), 152 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 4388007656..802c591ad8 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -14,6 +14,7 @@ racket/system rackunit/log pkg/lib + pkg/path setup/collects setup/getinfo) @@ -37,6 +38,13 @@ (define single-file? #t) +(define lock-file-dir (or (getenv "PLTLOCKDIR") + (find-system-path 'temp-dir))) +(define max-lock-delay (or (let ([n (string->number (or (getenv "PLTLOCKTIME") ""))]) + (and (real? n) + n)) + (* 4 60 60))) ; default: wait at most 4 hours + ;; Stub for running a test in a process: (module process racket/base (require rackunit/log) @@ -88,11 +96,15 @@ ;; Run each test in its own place or process, and collect both test ;; results and whether any output went to stderr. (define (dynamic-require-elsewhere p d args + #:id id #:mode [mode (or default-mode (if single-file? 'direct 'process))] - #:timeout [timeout default-timeout]) + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?) (define c (make-custodian)) (define timeout? #f) (with-handlers ([exn:fail? (lambda (exn) @@ -102,111 +114,131 @@ (extract-file-name p) (exn-message exn))) (summary 1 1 (current-label) #f (if timeout? 1 0)))]) - (define e (open-output-bytes)) + (define (go) + (define e (open-output-bytes)) - (define stdout (if quiet-program? - (open-output-nowhere) - (current-output-port))) - (define stderr (if quiet-program? - e - (if check-stderr? - (tee-output-port (current-error-port) e) - (current-error-port)))) + (define stdout (if quiet-program? + (open-output-nowhere) + (current-output-port))) + (define stderr (if quiet-program? + e + (if check-stderr? + (tee-output-port (current-error-port) e) + (current-error-port)))) - (define-values (result-code test-results) - (case mode - [(direct) - (define pre (test-log #:display? #f #:exit? #f)) - (define done? #f) - (define t - (parameterize ([current-output-port stdout] - [current-error-port stderr] - [current-command-line-arguments (list->vector args)]) - (thread - (lambda () - (dynamic-require p d) - ((executable-yield-handler) 0) - (set! done? #t))))) - (unless (thread? (sync/timeout timeout t)) - (set! timeout? #t) - (error 'test "timeout after ~a seconds" timeout)) - (unless done? - (error 'test "test raised an exception")) - (define post (test-log #:display? #f #:exit? #f)) - (values 0 - (cons (- (car post) (car pre)) - (- (cdr post) (cdr pre))))] - [(place) - ;; Start the test place: - (define-values (pl in out/f err/f) - (parameterize ([current-custodian c]) - (dynamic-place* '(submod compiler/commands/test place) - 'go - #:in (current-input-port) - #:out stdout - #:err stderr))) - - ;; Send the module path to test: - (place-channel-put pl (list p d (current-directory) args)) + (unless quiet? + (when responsible + (fprintf stdout "raco test:~a @(test-responsible '~s)\n" + id + responsible)) + (when random? + (fprintf stdout "raco test:~a @(test-random #t)\n" + id))) + + (define-values (result-code test-results) + (case mode + [(direct) + (define pre (test-log #:display? #f #:exit? #f)) + (define done? #f) + (define t + (parameterize ([current-output-port stdout] + [current-error-port stderr] + [current-command-line-arguments (list->vector args)]) + (thread + (lambda () + (dynamic-require p d) + ((executable-yield-handler) 0) + (set! done? #t))))) + (unless (thread? (sync/timeout timeout t)) + (set! timeout? #t) + (error 'test "timeout after ~a seconds" timeout)) + (unless done? + (error 'test "test raised an exception")) + (define post (test-log #:display? #f #:exit? #f)) + (values 0 + (cons (- (car post) (car pre)) + (- (cdr post) (cdr pre))))] + [(place) + ;; Start the test place: + (define-values (pl in out/f err/f) + (parameterize ([current-custodian c]) + (dynamic-place* '(submod compiler/commands/test place) + 'go + #:in (current-input-port) + #:out stdout + #:err stderr))) + + ;; Send the module path to test: + (place-channel-put pl (list p d (current-directory) args)) - ;; Wait for the place to finish: - (unless (sync/timeout timeout (place-dead-evt pl)) - (set! timeout? #t) - (error 'test "timeout after ~a seconds" timeout)) + ;; Wait for the place to finish: + (unless (sync/timeout timeout (place-dead-evt pl)) + (set! timeout? #t) + (error 'test "timeout after ~a seconds" timeout)) - ;; Get result code and test results: - (values (place-wait pl) - (sync/timeout 0 pl))] - [(process) - (define tmp-file (make-temporary-file)) - (define ps - (parameterize ([current-output-port stdout] - [current-error-port stderr] - [current-subprocess-custodian-mode 'kill] - [current-custodian c]) - (apply process*/ports - stdout - (current-input-port) - stderr - (find-exe) - "-l" - "racket/base" - "-e" - "(dynamic-require '(submod compiler/commands/test process) #f)" - tmp-file - (format "~s" (normalize-module-path p)) - (format "~s" d) - args))) - (define proc (list-ref ps 4)) - - (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) - (set! timeout? #t) - (error 'test "timeout after ~a seconds" timeout)) + ;; Get result code and test results: + (values (place-wait pl) + (sync/timeout 0 pl))] + [(process) + (define tmp-file (make-temporary-file)) + (define ps + (parameterize ([current-output-port stdout] + [current-error-port stderr] + [current-subprocess-custodian-mode 'kill] + [current-custodian c]) + (apply process*/ports + stdout + (current-input-port) + stderr + (find-exe) + "-l" + "racket/base" + "-e" + "(dynamic-require '(submod compiler/commands/test process) #f)" + tmp-file + (format "~s" (normalize-module-path p)) + (format "~s" d) + args))) + (define proc (list-ref ps 4)) + + (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) + (set! timeout? #t) + (error 'test "timeout after ~a seconds" timeout)) - (define results - (with-handlers ([exn:fail:read? (lambda () #f)]) - (call-with-input-file* tmp-file read))) - - (values (proc 'exit-code) - (and (pair? results) - (exact-positive-integer? (car results)) - (exact-positive-integer? (cdr results)) - results))])) - - ;; Shut down the place/process (usually a no-op unless it timed out): - (custodian-shutdown-all c) + (define results + (with-handlers ([exn:fail:read? (lambda () #f)]) + (call-with-input-file* tmp-file read))) + + (values (proc 'exit-code) + (and (pair? results) + (exact-positive-integer? (car results)) + (exact-positive-integer? (cdr results)) + results))])) + + ;; Shut down the place/process (usually a no-op unless it timed out): + (custodian-shutdown-all c) - ;; Check results: - (when check-stderr? - (unless (equal? #"" (get-output-bytes e)) - (error 'test "non-empty stderr: ~e" (get-output-bytes e)))) - (unless (zero? result-code) - (error 'test "non-zero exit: ~e" result-code)) - (cond - [test-results - (summary (car test-results) (cdr test-results) (current-label) #f 0)] - [else - (summary 0 1 (current-label) #f 0)]))) + ;; Check results: + (when check-stderr? + (unless (equal? #"" (get-output-bytes e)) + (error 'test "non-empty stderr: ~e" (get-output-bytes e)))) + (unless (zero? result-code) + (error 'test "non-zero exit: ~e" result-code)) + (cond + [test-results + (summary (car test-results) (cdr test-results) (current-label) #f 0)] + [else + (summary 0 1 (current-label) #f 0)])) + + ;; Serialize the above with a lock, if any: + (if lock-name + (call-with-file-lock/timeout + #:max-delay max-lock-delay + (build-path lock-file-dir lock-name) + 'exclusive + go + (lambda () (error 'test "could not obtain lock: ~s" lock-name))) + (go)))) ;; For recording stderr while also propagating to the original stderr: (define (tee-output-port p1 p2) @@ -242,7 +274,14 @@ (append mod '(config)) (error 'test "cannot add test-config submodule to path: ~s" mod))) -(define (dynamic-require* p d args try-config?) +(define (dynamic-require* p d + #:id id + #:try-config? try-config? + #:args args + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?) (define lookup (or (cond [(not try-config?) #f] @@ -252,10 +291,17 @@ (lambda (what get-default) (get-default)))) (dynamic-require-elsewhere p d args + #:id id + #:responsible (lookup 'responsible + (lambda () responsible)) #:timeout (if default-timeout (lookup 'timeout - (lambda () default-timeout)) - +inf.0))) + (lambda () timeout)) + +inf.0) + #:lock-name (lookup 'lock-name + (lambda () lock-name)) + #:random? (lookup 'random? + (lambda () random?)))) (define current-label (make-parameter "???")) (struct summary (failed total label body-res timeout)) @@ -370,7 +416,14 @@ ;; Perform test of one module (in parallel, as allowed by ;; `task-sema`): -(define (test-module p mod args try-config? #:sema continue-sema) +(define (test-module p mod + #:sema continue-sema + #:try-config? try-config? + #:args [args '()] + #:timeout [timeout +inf.0] + #:responsible [responsible #f] + #:lock-name [lock-name #f] + #:random? [random? #f]) (call-with-semaphore task-sema ; limits parallelism (lambda () @@ -397,7 +450,16 @@ (flush-output)) id))) (begin0 - (dynamic-require* mod 0 args try-config?) + (dynamic-require* mod 0 + #:id (if (jobs . <= . 1) + "" + (format " ~a" id)) + #:try-config? try-config? + #:args args + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?) (call-with-semaphore ids-lock (lambda () @@ -416,7 +478,9 @@ (cond [(directory-exists? p) (set! single-file? #f) - (if (omit-path? (path->directory-path p)) + (define dir-p (path->directory-path p)) + (check-info dir-p) + (if (omit-path? dir-p) (summary 0 0 #f null 0) (with-summary `(directory ,p) @@ -431,13 +495,29 @@ (or (not check-suffix?) (regexp-match rx:default-suffixes p) (get-cmdline p #f)) - (not (omit-path? p))) - (define args (get-cmdline p)) + (begin (check-info p) + (not (omit-path? p)))) + ;; The above `omit-path?` loads "info.rkt" files + (define norm-p (normalize-info-path p)) + (define args (get-cmdline norm-p)) + (define timeout (get-timeout norm-p)) + (define lock-name (get-lock-name norm-p)) + (define responsible (get-responsible norm-p)) + (define random? (get-random norm-p)) (parameterize ([current-directory (let-values ([(base name dir?) (split-path p)]) (if (path? base) base (current-directory)))]) (define file-name (file-name-from-path p)) + (define (test-this-module mod try-config?) + (test-module p mod + #:try-config? try-config? + #:sema continue-sema + #:args args + #:timeout timeout + #:responsible responsible + #:lock-name lock-name + #:random? random?)) (with-summary `(file ,p) (let ([something-wasnt-declared? #f] @@ -454,13 +534,13 @@ #f] [(module-declared? mod #t) (set! did-one? #t) - (test-module p mod args #t #:sema continue-sema)] + (test-this-module mod #t)] [else (set! something-wasnt-declared? #t) #f])) (list (and (and run-anyways? something-wasnt-declared?) - (test-module p file-name args #f #:sema continue-sema))))))))] + (test-this-module file-name #f))))))))] [(not (file-exists? p)) (error 'test "given path ~e does not exist" p)] [else (summary 0 0 #f null 0)])])) @@ -559,11 +639,16 @@ (define omit-paths (make-hash)) (define command-line-arguments (make-hash)) +(define timeouts (make-hash)) +(define lock-names (make-hash)) +(define responsibles (make-hash)) +(define randoms (make-hash)) +(define pkg-cache (make-hash)) (define collects-cache (make-hash)) (define info-done (make-hash)) -(define (check-info p check-up?) +(define (check-dir-info p) (define-values (base name dir?) (split-path p)) (define dir (normalize-info-path (if dir? @@ -572,60 +657,91 @@ (path->complete-path base) (current-directory))))) - (when (and check-up? (not dir?)) - ;; Check enclosing collection - (define c (path->collects-relative p #:cache collects-cache)) - (when (list? c) - (check-info/parents dir - (apply build-path (map bytes->path (reverse (cdr (reverse (cdr c))))))))) - (unless (hash-ref info-done dir #f) (hash-set! info-done dir #t) (define info (get-info/full dir)) (when info - (define v (info 'test-omit-paths (lambda () '()))) (define (bad what v) (log-error "bad `~a' in \"info.rkt\": ~e" what v)) - (cond - [(eq? v 'all) - (hash-set! omit-paths dir #t)] - [(list? v) - (for ([i (in-list v)]) - (unless (path-string? i) (bad 'test-omit-paths v)) - (define p (normalize-info-path (path->complete-path i dir))) - (define dp (if (directory-exists? p) - (path->directory-path p) - p)) - (hash-set! omit-paths dp #t))] - [else (bad 'test-omit-paths v)]) - (define a (info 'test-command-line-arguments (lambda () '()))) - (unless (list? a) (bad 'test-command-line-arguments a)) - (for ([arg (in-list a)]) - (unless (and (list? arg) - (= 2 (length arg)) - (path-string? (car arg)) - (list? (cadr arg)) - (andmap path-string? (cadr arg))) - (bad 'test-command-line-arguments a)) - (hash-set! command-line-arguments - (normalize-info-path (path->complete-path (car arg) dir)) - (cadr arg)))))) + (define (get-members table what all-ok?) + (define v (info what (lambda () '()))) + (cond + [(and all-ok? (eq? v 'all)) + (hash-set! table dir #t)] + [(list? v) + (for ([i (in-list v)]) + (unless (path-string? i) (bad what v)) + (define p (normalize-info-path (path->complete-path i dir))) + (define dp (if (directory-exists? p) + (path->directory-path p) + p)) + (hash-set! table dp #t))] + [else (bad what v)])) + (get-members omit-paths 'test-omit-paths #t) + (get-members randoms 'test-randoms #t) + + (define (get-keyed table what check? #:ok-all? [ok-all? #f]) + (define a (info what (lambda () '()))) + (if (list? a) + (for ([arg (in-list a)]) + (unless (and (list? arg) + (= 2 (length arg)) + (or (path-string? (car arg)) + (and ok-all? + (eq? (car arg) 'all))) + (check? (cadr arg))) + (bad what a)) + (hash-set! table + (normalize-info-path (if (eq? (car arg) 'all) + dir + (path->complete-path (car arg) dir))) + (cadr arg))) + (bad what a))) + + (get-keyed command-line-arguments + 'test-command-line-arguments + (lambda (v) (and (list? v) + (andmap path-string? v)))) + (get-keyed timeouts + 'test-timeouts + (lambda (v) (real? v))) + (get-keyed lock-names + 'test-lock-names + (lambda (v) (or (not v) + (and (string? v) + (path-string? v))))) + (get-keyed responsibles + 'test-responsibles + ok-responsible? + #:ok-all? #t) + (get-keyed randoms + 'test-random + (lambda (v) (string? v)))))) (define (check-info/parents dir subpath) (let loop ([dir dir] [subpath subpath]) - (unless (hash-ref info-done dir #f) - (check-info dir #f) - (define-values (next-subpath subpath-name subpath-dir?) (split-path subpath)) - (define-values (next-dir dir-name dir-dir?) (split-path dir)) - (when (path? next-subpath) - (loop next-dir next-subpath))))) + (check-dir-info dir) + (define-values (next-subpath subpath-name subpath-dir?) (split-path subpath)) + (define-values (next-dir dir-name dir-dir?) (split-path dir)) + (when (path? next-subpath) + (loop next-dir next-subpath)))) + +(define (check-info p) + (check-dir-info p) + ;; Check enclosing collection + (define-values (base name dir?) (split-path p)) + (define c (if dir? + #f + (path->collects-relative p #:cache collects-cache))) + (when (list? c) + (check-info/parents base + (apply build-path (map bytes->path (reverse (cdr (reverse (cdr c))))))))) (define (normalize-info-path p) (simplify-path (path->complete-path p) #f)) (define (omit-path? p) - (check-info p #t) (let ([p (normalize-info-path p)]) (or (hash-ref omit-paths p #f) (let-values ([(base name dir?) (split-path p)]) @@ -633,8 +749,40 @@ (omit-path? base)))))) (define (get-cmdline p [default null]) - (let ([p (normalize-info-path p)]) - (hash-ref command-line-arguments p default))) + (hash-ref command-line-arguments p default)) + +(define (get-timeout p) (hash-ref timeouts p +inf.0)) + +(define (get-lock-name p) (hash-ref lock-names p #f)) + +(define (get-responsible p) + (or (let loop ([p p]) + (or (hash-ref responsibles p #f) + (let-values ([(base name dir?) (split-path p)]) + (and (path? base) + (loop base))))) + ;; Check package authors: + (let-values ([(pkg subpath) (path->pkg+subpath p #:cache pkg-cache)]) + (and pkg + (let ([pkg-dir (if (path? subpath) + (apply build-path + (drop-right (explode-path p) + (length (explode-path subpath)))) + pkg)]) + (define info (get-info/full pkg-dir)) + (and info + (let ([v (info 'pkg-authors (lambda () #f))]) + (and (ok-responsible? v) + v)))))))) + +(define (get-random p) (hash-ref randoms p #f)) + +(define (ok-responsible? v) + (or (string? v) + (symbol? v) + (and (list? v) + (andmap (lambda (v) (or (symbol? v) (string? v))) + v)))) ;; -------------------------------------------------- From a536f2adeb0b153b4f4e328a8bfaa382ac51cce1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 31 Dec 2013 17:05:39 -0700 Subject: [PATCH 359/466] copy `responsible` info to "info.rkt" files It seems more ideal that `pkg-authors` would be specific enough responsibility, but our existing allocations of responsibility are more fine-grained, and we keep them for now. original commit: 19f8f30f63ece380105f69796c046c7a00aa4f97 --- pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt | 2 ++ .../compiler-pkgs/compiler-lib/compiler/demodularizer/info.rkt | 3 +++ pkgs/compiler-pkgs/compiler-test/tests/compiler/info.rkt | 3 +++ 3 files changed, 8 insertions(+) create mode 100644 pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/info.rkt create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/info.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt index 1b766b6c9f..b7f1ac48d0 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt @@ -10,3 +10,5 @@ ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f))) + +(define test-responsibles '(("test.rkt" jay))) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/info.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/info.rkt new file mode 100644 index 0000000000..84ad0ac2d5 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define test-responsibles '((all jay))) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/info.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/info.rkt new file mode 100644 index 0000000000..84ad0ac2d5 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define test-responsibles '((all jay))) From 02cafbccb6bc95453a6d2e0ce9746307305a4641 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 6 Jan 2014 18:00:29 -0500 Subject: [PATCH 360/466] Fix raco test on relative paths. original commit: 3a025efcceeeae011afd6b47fa8ad8ff34e4d7ff --- pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 802c591ad8..b339eacd46 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -735,7 +735,9 @@ #f (path->collects-relative p #:cache collects-cache))) (when (list? c) - (check-info/parents base + (check-info/parents (if (path? base) + (path->complete-path base) + (current-directory)) ; got 'relative (apply build-path (map bytes->path (reverse (cdr (reverse (cdr c))))))))) (define (normalize-info-path p) From c6e34673eef8f0c2fddf880eda9573b121d7e469 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Mon, 13 Jan 2014 00:04:08 -0800 Subject: [PATCH 361/466] Make parallel compile not call exit. Closes PR 13373. original commit: f0ebfee9ac71d1cb141400cc77295bf5a6a1dfbc --- .../compiler-lib/compiler/commands/make.rkt | 33 ++++++++++--------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt index 74fd5ff6ce..a0f67f1e5d 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt @@ -98,19 +98,20 @@ dest)))))))] ;; Parallel make: [else - (parallel-compile-files - source-files - #:worker-count (worker-count) - #:handler (lambda (type work msg out err) - (match type - ['done (when (verbose) (printf " Made ~a\n" work))] - ['output (printf " Output from: ~a\n~a~a" work out err)] - [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])) - #:options (let ([cons-if-true (lambda (bool carv cdrv) - (if bool - (cons carv cdrv) - cdrv))]) - (cons-if-true - (very-verbose) - 'very-verbose - (cons-if-true (disable-inlining) 'disable-inlining null))))]) + (or (parallel-compile-files + source-files + #:worker-count (worker-count) + #:handler (lambda (type work msg out err) + (match type + ['done (when (verbose) (printf " Made ~a\n" work))] + ['output (printf " Output from: ~a\n~a~a" work out err)] + [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])) + #:options (let ([cons-if-true (lambda (bool carv cdrv) + (if bool + (cons carv cdrv) + cdrv))]) + (cons-if-true + (very-verbose) + 'very-verbose + (cons-if-true (disable-inlining) 'disable-inlining null)))) + (exit 1))]) From 6aec40ebfb21978d277c5ef64e604124ad6015d3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 21 Jan 2014 15:02:21 -0500 Subject: [PATCH 362/466] 2013 -> 2014 original commit: c61a549840ee0ba5f2e5da56523fd3b26efeb895 --- pkgs/compiler-pkgs/compiler-lib/LICENSE.txt | 2 +- pkgs/compiler-pkgs/compiler-test/LICENSE.txt | 2 +- pkgs/compiler-pkgs/compiler/LICENSE.txt | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt b/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt index f92b4cdd12..898bab7e25 100644 --- a/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt @@ -1,5 +1,5 @@ compiler-lib -Copyright (c) 2010-2013 PLT Design Inc. +Copyright (c) 2010-2014 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link Racket into proprietary diff --git a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt index 7fe458f3a0..77a54cde3e 100644 --- a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt @@ -1,5 +1,5 @@ compiler-test -Copyright (c) 2010-2013 PLT Design Inc. +Copyright (c) 2010-2014 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link Racket into proprietary diff --git a/pkgs/compiler-pkgs/compiler/LICENSE.txt b/pkgs/compiler-pkgs/compiler/LICENSE.txt index f9369366b3..0cd0292e38 100644 --- a/pkgs/compiler-pkgs/compiler/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler/LICENSE.txt @@ -1,5 +1,5 @@ compiler -Copyright (c) 2010-2013 PLT Design Inc. +Copyright (c) 2010-2014 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link Racket into proprietary From ec06cc8428987e326a374c29547794decceded93 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 25 Feb 2014 14:54:40 -0700 Subject: [PATCH 363/466] add PLTUSERHOME The new `PLTUSERHOME` environment variable redirects all of the user-specific paths reported by `find-system-path`. Also, improve the tests for `raco exe` (particularly the bug fixed in 6cb6f3fbf1) using `PLTUSERHOME`. original commit: e4ce0d033150a4523d0bd76c7b16fccefd9081a3 --- .../tests/compiler/embed/test.rkt | 44 ++++++++++--------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt index 6588421ca8..c56c8fd9e5 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt @@ -53,28 +53,30 @@ (let ([plthome (getenv "PLTHOME")] [collects (getenv "PLTCOLLECTS")] [out (open-output-string)]) + (define temp-home-dir (make-temporary-file "racket-tmp-home~a" 'directory)) ;; Try to hide usual collections: - (when plthome - (putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) - (when collects - (putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) - ;; Execute: - (parameterize ([current-directory (find-system-path 'temp-dir)]) - (when (file-exists? "stdout") - (delete-file "stdout")) - (let ([path (if (and mred? (eq? 'macosx (system-type))) - (let-values ([(base name dir?) (split-path exe)]) - (build-path exe "Contents" "MacOS" - (path-replace-suffix name #""))) - exe)]) - (test #t - path - (parameterize ([current-output-port out]) - (system* path))))) - (when plthome - (putenv "PLTHOME" plthome)) - (when collects - (putenv "PLTCOLLECTS" collects)) + (parameterize ([current-environment-variables + (environment-variables-copy + (current-environment-variables))]) + (putenv "PLTUSERHOME" (path->string temp-home-dir)) + (when plthome + (putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) + (when collects + (putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE")))) + ;; Execute: + (parameterize ([current-directory (find-system-path 'temp-dir)]) + (when (file-exists? "stdout") + (delete-file "stdout")) + (let ([path (if (and mred? (eq? 'macosx (system-type))) + (let-values ([(base name dir?) (split-path exe)]) + (build-path exe "Contents" "MacOS" + (path-replace-suffix name #""))) + exe)]) + (test #t + path + (parameterize ([current-output-port out]) + (system* path)))))) + (delete-directory/files temp-home-dir) (let ([stdout-file (build-path (find-system-path 'temp-dir) "stdout")]) (if (file-exists? stdout-file) (test expect with-input-from-file stdout-file From 7faccf058af8ce122a10949d9c501db74bc8472b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Feb 2014 14:42:59 -0700 Subject: [PATCH 364/466] LGPL by reference original commit: 981701d2378179d4ada54b7fd2608df3b89748fd --- pkgs/compiler-pkgs/compiler-lib/LICENSE.txt | 3 ++- pkgs/compiler-pkgs/compiler-test/LICENSE.txt | 3 ++- pkgs/compiler-pkgs/compiler/LICENSE.txt | 3 ++- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt b/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt index 898bab7e25..ccfab19fda 100644 --- a/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt @@ -7,4 +7,5 @@ applications, provided you follow the rules stated in the LGPL. You can also modify this package; if you distribute a modified version, you must distribute it under the terms of the LGPL, which in particular means that you must release the source code for the -modified software. See COPYING_LESSER.txt for more information. +modified software. See http://www.gnu.org/copyleft/lesser.html +for more information. diff --git a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt index 77a54cde3e..d2fa970321 100644 --- a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt @@ -7,4 +7,5 @@ applications, provided you follow the rules stated in the LGPL. You can also modify this package; if you distribute a modified version, you must distribute it under the terms of the LGPL, which in particular means that you must release the source code for the -modified software. See COPYING_LESSER.txt for more information. +modified software. See http://www.gnu.org/copyleft/lesser.html +for more information. diff --git a/pkgs/compiler-pkgs/compiler/LICENSE.txt b/pkgs/compiler-pkgs/compiler/LICENSE.txt index 0cd0292e38..06aa96254b 100644 --- a/pkgs/compiler-pkgs/compiler/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler/LICENSE.txt @@ -7,4 +7,5 @@ applications, provided you follow the rules stated in the LGPL. You can also modify this package; if you distribute a modified version, you must distribute it under the terms of the LGPL, which in particular means that you must release the source code for the -modified software. See COPYING_LESSER.txt for more information. +modified software. See http://www.gnu.org/copyleft/lesser.html +for more information. From 90f45301b8d658b7da0fc48a72a2d83f0e5084be Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 8 Apr 2014 08:03:57 -0600 Subject: [PATCH 365/466] raco decompile: fix for `#%foreign` Merge to v6.0.1 original commit: e9b97c494c5dbe3fe27d29f18a1f93a3dcfffc5f --- pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt | 1 + pkgs/plt-services/meta/drdr2/master/master.rkt | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) delete mode 100644 pkgs/plt-services/meta/drdr2/master/master.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt index 3edead45c4..8f5e35bced 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt @@ -21,6 +21,7 @@ (namespace-require ''#%flfxnum) (namespace-require ''#%extfl) (namespace-require ''#%futures) + (namespace-require ''#%foreign) (for/list ([l (namespace-mapped-symbols)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))))))] diff --git a/pkgs/plt-services/meta/drdr2/master/master.rkt b/pkgs/plt-services/meta/drdr2/master/master.rkt deleted file mode 100644 index 6f1f7b4de3..0000000000 --- a/pkgs/plt-services/meta/drdr2/master/master.rkt +++ /dev/null @@ -1 +0,0 @@ -#lang racket From 79a884aa432208aeb2c239e6f1c54da0a8510293 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 23 Apr 2014 17:50:25 -0400 Subject: [PATCH 366/466] Add -l flag to `raco test`. Behaves similarly to `-l` for plain `racket`. original commit: cff3c41e01dc4afd72db4eceb75381020d33c175 --- .../compiler-lib/compiler/commands/test.rkt | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index b339eacd46..41e56acfc2 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -608,6 +608,7 @@ (define collections? #f) (define packages? #f) +(define libraries? #f) (define check-top-suffix? #f) (define (test-top e @@ -621,7 +622,18 @@ [l (with-summary `(collection ,e) - (map/parallel test-files l #:sema continue-sema))])] + (map/parallel test-files (collection-file-path l) #:sema continue-sema))])] + [libraries? + (define (find x) + (define rmp ((current-module-name-resolver) x #f #f #f)) + (define p (resolved-module-path-name rmp)) + (and (file-exists? p) p)) + (match (find (string->symbol e)) + [#f (error 'test "Library ~e does not exist" e)] + [l + (with-summary + `(library ,l) + (test-files l #:sema continue-sema))])] [packages? (define pd (pkg-directory e)) (if pd @@ -803,6 +815,9 @@ [("--collection" "-c") "Interpret arguments as collections" (set! collections? #t)] + [("--lib" "-l") + "Interpret arguments as libraries" + (set! libraries? #t)] [("--package" "-p") "Interpret arguments as packages" (set! packages? #t)] From 38f585181ef109b9b96ee26f80587f3d6aa6bf7f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 Apr 2014 14:36:33 -0600 Subject: [PATCH 367/466] raco dist: preserve relative location of runtime files only within a package Previously, relative locations were preserved for all files with the same root, but that tends to keep too much information about the original filesystem layout, especially when runtime files are pulled both from the installation and a user-specific area. Since packages can be installed at different relative locations, it makes sense to preserve relative locations only up to package boundaries. original commit: 5c909cca0ddccb9c79d2a08a5764a7d48e4714d7 --- .../tests/compiler/embed/embed-me1f.rkt | 12 ++++++++++++ .../tests/compiler/embed/embed-me1f1.rktl | 1 + .../tests/compiler/embed/sub/embed-me1f2.rktl | 1 + .../compiler-test/tests/compiler/embed/test.rkt | 1 + 4 files changed, 15 insertions(+) create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f1.rktl create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt new file mode 100644 index 0000000000..124a44cb48 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt @@ -0,0 +1,12 @@ +#lang scheme/base + +(require scheme/runtime-path) + +;; Check that relative paths are preserved: +(define-runtime-path f1 "embed-me1f1.rktl") +(define-runtime-path f2 "sub/embed-me1f2.rktl") + +(with-output-to-file "stdout" + (lambda () (parameterize ([current-namespace (make-base-namespace)]) + (load f1))) + #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f1.rktl b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f1.rktl new file mode 100644 index 0000000000..5e2940e678 --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f1.rktl @@ -0,0 +1 @@ +(load-relative "sub/embed-me1f2.rktl") diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl new file mode 100644 index 0000000000..a70455650f --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl @@ -0,0 +1 @@ +(printf "This is 1f\n") diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt index 0d13194071..e2609d1f6a 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt @@ -236,6 +236,7 @@ (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f) (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) + (one-mz-test "embed-me1f.rkt" "This is 1f\n" #f) (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) (one-mz-test "embed-me13.rkt" "This is 14\n" #f) (one-mz-test "embed-me14.rkt" "This is 14\n" #f) From 633ec1faf524947862fdebedd03c942eb98cb274 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 10 May 2014 11:11:52 -0500 Subject: [PATCH 368/466] fix raco test -c closes PR 14494 original commit: fa68b57de3550aeb4656998eb4dc8de2f45f8195 --- pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 41e56acfc2..86c7e6f332 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -622,7 +622,7 @@ [l (with-summary `(collection ,e) - (map/parallel test-files (collection-file-path l) #:sema continue-sema))])] + (map/parallel test-files l #:sema continue-sema))])] [libraries? (define (find x) (define rmp ((current-module-name-resolver) x #f #f #f)) From 03a0dbd9fd4831248c09f68d9267760a7643fcff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 26 May 2014 18:17:45 +0100 Subject: [PATCH 369/466] raco make: improve parallelism The `require` macro now logs "prefetch" messages when it sees a `require` with multiple module paths. The prefix information is approximate, since parsing a `require` subform might depend on imports from a previous subform, but in the common case, there are many obvious module paths to prefetch. The parallel mode of `raco make` watches for prefetch messages and records the suggested "prefetch" paths so they can be compiled by other processes. original commit: 9e3b984463e1aa222f9843bd0efc8b2909bfed17 --- .../compiler-lib/compiler/commands/make.rkt | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt index a0f67f1e5d..15c8d7bd4b 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt @@ -5,6 +5,7 @@ compiler/compiler dynext/file setup/parallel-build + setup/path-to-relative racket/match) (module test racket/base) @@ -97,15 +98,19 @@ (if did-one? "output to" "already up-to-date at") dest)))))))] ;; Parallel make: - [else + [else + (define path-cache (make-hash)) (or (parallel-compile-files source-files #:worker-count (worker-count) - #:handler (lambda (type work msg out err) + #:handler (lambda (id type work msg out err) + (define (->rel p) + (path->relative-string/library p #:cache path-cache)) (match type - ['done (when (verbose) (printf " Made ~a\n" work))] - ['output (printf " Output from: ~a\n~a~a" work out err)] - [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])) + ['start (when (verbose) (printf " ~a making ~a\n" id (->rel work)))] + ['done (when (verbose) (printf " ~a made ~a\n" id (->rel work)))] + ['output (printf " ~a output from: ~a\n~a~a" id work out err)] + [else (printf " ~a error compiling ~a\n~a\n~a~a" id work msg out err)])) #:options (let ([cons-if-true (lambda (bool carv cdrv) (if bool (cons carv cdrv) From 979299850eeda4b714e9a10c99a07d598b696b4e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 May 2014 06:34:19 +0100 Subject: [PATCH 370/466] raco decompile: improve argument checking and reporting Relevant to PR 14525 original commit: e4189afb15ce0fa5aa10fd218f5b00143ffa4f93 --- .../compiler/commands/decompile.rkt | 59 ++++++++++++++++++- 1 file changed, 57 insertions(+), 2 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt index 004693fc5a..57b7f55af0 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt @@ -3,25 +3,80 @@ raco/command-name compiler/zo-parse compiler/decompile - racket/pretty) + racket/pretty + racket/format) + +(define (get-name) + (string->symbol (short-program+command-name))) + +(define force? #f) (define source-files (command-line #:program (short-program+command-name) #:once-each + [("--force") "Ignore timestamp mimatch on associated \".zo\"" + (set! force? #t)] [("--columns" "-n") n "Format for columns" (let ([num (string->number n)]) (unless (exact-positive-integer? num) - (raise-user-error (string->symbol (short-program+command-name)) + (raise-user-error (get-name) "not a valid column count: ~a" n)) (pretty-print-columns num))] #:args source-or-bytecode-file source-or-bytecode-file)) +(define (check-files orig-file alt-file) + (cond + [(not (file-exists? alt-file)) + (cond + [(file-exists? orig-file) + (unless (is-bytecode-file? orig-file) + (raise-user-error (get-name) + (~a "not a bytecode file, and no associated \".zo\" file\n" + " path: ~a\n" + " tried associated path: ~a") + orig-file + alt-file))] + [else + (raise-user-error (get-name) + (~a "no such file, and no associated \".zo\" file\n" + " path: ~a\n" + " tried associated path: ~a") + orig-file + alt-file)])] + [(not (is-bytecode-file? alt-file)) + (raise-user-error (get-name) + (~a "associated \".zo\" file is not a bytecode file\n" + " original path: ~a\n" + " associated path: ~a") + orig-file + alt-file)] + [(and (not force?) + ((file-or-directory-modify-seconds orig-file) + . > . + (file-or-directory-modify-seconds alt-file))) + ;; return a warning: + (raise-user-error (get-name) + (~a "associated \".zo\" file's date is older than given file's date;\n" + " consider using `raco make` to rebuild the source file, or use `--force`\n" + " to skip the date check\n" + " original path: ~a\n" + " associated path: ~a") + orig-file + alt-file)])) + +(define (is-bytecode-file? orig-file) + (call-with-input-file* + orig-file + (lambda (i) + (equal? #"#~" (read-bytes 2 i))))) + (for ([zo-file source-files]) (let ([zo-file (path->complete-path zo-file)]) (let-values ([(base name dir?) (split-path zo-file)]) (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))]) + (check-files zo-file alt-file) (parameterize ([current-load-relative-directory base] [print-graph #t]) (pretty-write From 7fdf264e1dcd992d32d6d058f6324299d8d44bad Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 May 2014 08:30:24 +0100 Subject: [PATCH 371/466] raco {make,decompile}: fix bytecode path calculation Use `compiler/compilation-path` to take into account PLTCOMPILEDROOTS, etc. Closes PR 14525 original commit: 5ad11c85e67318c36b4c8e070daa9f81f37f28c5 --- .../compiler-lib/compiler/commands/decompile.rkt | 3 ++- .../compiler-lib/compiler/commands/make.rkt | 13 +++++-------- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt index 57b7f55af0..fd6a2a4261 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt @@ -3,6 +3,7 @@ raco/command-name compiler/zo-parse compiler/decompile + compiler/compilation-path racket/pretty racket/format) @@ -75,7 +76,7 @@ (for ([zo-file source-files]) (let ([zo-file (path->complete-path zo-file)]) (let-values ([(base name dir?) (split-path zo-file)]) - (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))]) + (let ([alt-file (get-compilation-bytecode-file zo-file)]) (check-files zo-file alt-file) (parameterize ([current-load-relative-directory base] [print-graph #t]) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt index 15c8d7bd4b..2724b49057 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt @@ -3,6 +3,7 @@ raco/command-name compiler/cm compiler/compiler + compiler/compilation-path dynext/file setup/parallel-build setup/path-to-relative @@ -89,14 +90,10 @@ [compile-enforce-module-constants (not (disable-const))]) (managed-compile-zo file)) - (let ([dest (append-zo-suffix - (let-values ([(base name dir?) (split-path file)]) - (build-path (if (symbol? base) 'same base) - "compiled" name)))]) - (when (verbose) - (printf " [~a \"~a\"]\n" - (if did-one? "output to" "already up-to-date at") - dest)))))))] + (when (verbose) + (printf " [~a \"~a\"]\n" + (if did-one? "output to" "already up-to-date at") + (get-compilation-bytecode-file file)))))))] ;; Parallel make: [else (define path-cache (make-hash)) From 4381f1eb240b7a5412798085949eecd0d6f45494 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Jun 2014 20:40:24 +0100 Subject: [PATCH 372/466] raco decompile: fix for bytecode without source original commit: 3f75bc21d93c2cedfddad00c533af091d6b999f5 --- .../compiler-lib/compiler/commands/decompile.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt index fd6a2a4261..bada535b72 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt @@ -54,7 +54,9 @@ orig-file alt-file)] [(and (not force?) - ((file-or-directory-modify-seconds orig-file) + ((file-or-directory-modify-seconds orig-file + #f + (lambda () -inf.0)) . > . (file-or-directory-modify-seconds alt-file))) ;; return a warning: From fce59c1521b5ed07f48440964bd2f09763f43ab2 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 30 May 2014 18:42:31 -0600 Subject: [PATCH 373/466] Ensure that explicit arguments are always run even when ignored by info.rkt original commit: 4b1cb56b99111555d0ddfbf6135aeda76cb9a7af --- .../compiler-lib/compiler/commands/test.rkt | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 86c7e6f332..1a70821686 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -495,8 +495,9 @@ (or (not check-suffix?) (regexp-match rx:default-suffixes p) (get-cmdline p #f)) - (begin (check-info p) - (not (omit-path? p)))) + (or explicit-arguments? + (begin (check-info p) + (not (omit-path? p))))) ;; The above `omit-path?` loads "info.rkt" files (define norm-p (normalize-info-path p)) (define args (get-cmdline norm-p)) @@ -607,6 +608,7 @@ (require (submod "." paths)) (define collections? #f) +(define explicit-arguments? #f) (define packages? #f) (define libraries? #f) (define check-top-suffix? #f) @@ -885,7 +887,9 @@ "Print a summary table" (set! table? #t)] #:args file-or-directory - (begin (unless (= 1 (length file-or-directory)) + (begin (set! explicit-arguments? + (not (or collections? libraries? packages? check-top-suffix?))) + (unless (= 1 (length file-or-directory)) (set! single-file? #f)) (define sum ;; The #:sema argument everywhre makes tests start From 9f37438fe0a0d9c19deb4c0cefb7c32f2212e43a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Jun 2014 07:38:37 +0100 Subject: [PATCH 374/466] raco test: create fresh user directory for each test in DrDr mode original commit: 2d3b856b718aed2fb3f8202dc321ef4e93d2fb96 --- .../compiler-lib/compiler/commands/test.rkt | 52 +++++++++++++++++-- 1 file changed, 47 insertions(+), 5 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 1a70821686..e3d583b1dc 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -29,6 +29,8 @@ (define quiet-program? #f) (define check-stderr? #f) (define table? #f) +(define fresh-user? #f) +(define empty-input? #f) (define jobs 0) ; 0 mean "default" (define task-sema (make-semaphore 1)) @@ -47,7 +49,8 @@ ;; Stub for running a test in a process: (module process racket/base - (require rackunit/log) + (require rackunit/log + racket/file) ;; Arguments are a temp file to hold test results, the module ;; path to run, and the `dynamic-require` second argument: (define argv (current-command-line-arguments)) @@ -56,6 +59,12 @@ (define d (read (open-input-string (vector-ref argv 2)))) (define args (list-tail (vector->list argv) 3)) + ;; In case PLTUSERHOME is set, make sure relevant + ;; directories exist: + (define (ready-dir d) + (make-directory* d)) + (ready-dir (find-system-path 'doc-dir)) + (parameterize ([current-command-line-arguments (list->vector args)]) (dynamic-require test-module d) ((executable-yield-handler) 0)) @@ -125,6 +134,9 @@ (if check-stderr? (tee-output-port (current-error-port) e) (current-error-port)))) + (define stdin (if empty-input? + (open-input-bytes #"") + (current-input-port))) (unless quiet? (when responsible @@ -133,7 +145,11 @@ responsible)) (when random? (fprintf stdout "raco test:~a @(test-random #t)\n" - id))) + id)) + (when lock-name + (fprintf stdout "raco test:~a @(lock-name ~s)\n" + id + lock-name))) (define-values (result-code test-results) (case mode @@ -143,6 +159,7 @@ (define t (parameterize ([current-output-port stdout] [current-error-port stderr] + [current-input-port stdin] [current-command-line-arguments (list->vector args)]) (thread (lambda () @@ -164,7 +181,7 @@ (parameterize ([current-custodian c]) (dynamic-place* '(submod compiler/commands/test place) 'go - #:in (current-input-port) + #:in stdin #:out stdout #:err stderr))) @@ -181,14 +198,27 @@ (sync/timeout 0 pl))] [(process) (define tmp-file (make-temporary-file)) + (define tmp-dir (and fresh-user? + (make-temporary-file "home~a" 'directory))) (define ps (parameterize ([current-output-port stdout] [current-error-port stderr] [current-subprocess-custodian-mode 'kill] - [current-custodian c]) + [current-custodian c] + [current-environment-variables (environment-variables-copy + (current-environment-variables))]) + (environment-variables-set! (current-environment-variables) + #"PLTUSERHOME" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"TMPDIR" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"PLTADDONDIR" + (path->bytes (find-system-path 'addon-dir))) (apply process*/ports stdout - (current-input-port) + stdin stderr (find-exe) "-l" @@ -208,6 +238,10 @@ (define results (with-handlers ([exn:fail:read? (lambda () #f)]) (call-with-input-file* tmp-file read))) + + (delete-file tmp-file) + (when tmp-dir + (delete-directory/files tmp-dir)) (values (proc 'exit-code) (and (pair? results) @@ -832,12 +866,14 @@ "Configure defaults to imitate DrDr" (set! check-top-suffix? #t) (set! first-avail? #t) + (set! empty-input? #t) (when (zero? jobs) (set-jobs! (processor-count))) (unless default-timeout (set! default-timeout 90)) (set! check-stderr? #t) (set! quiet-program? #t) + (set! fresh-user? #t) (set! table? #t) (unless default-mode (set! default-mode 'process))] @@ -874,12 +910,18 @@ [("--timeout") seconds "Set default timeout to " (set! default-timeout (string->number* "timeout" seconds real?))] + [("--fresh-user") + "Fresh PLTUSERHOME, etc., for each test" + (set! fresh-user? #t)] [("--quiet-program" "-Q") "Quiet the program" (set! quiet-program? #t)] [("--check-stderr" "-e") "Treat stderr output as a test failure" (set! check-stderr? #t)] + [("--empty-stdin") + "Call program with an empty stdin" + (set! empty-input? #t)] [("--quiet" "-q") "Suppress `raco test: ...' message" (set! quiet? #t)] From 7380ec5e0e242362afa41f8fa7fc5f08014f3811 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Jun 2014 08:31:01 +0100 Subject: [PATCH 375/466] raco test: add `++ignore-stderr ` option I'm using this option to ignore "Xlib: extension \"RANDR\" missing" warnings. original commit: a011f9b816fe8edc2c47a9416eb13839309a8979 --- .../compiler-lib/compiler/commands/test.rkt | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index e3d583b1dc..8424525255 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -31,6 +31,7 @@ (define table? #f) (define fresh-user? #f) (define empty-input? #f) +(define ignore-stderr-patterns null) (define jobs 0) ; 0 mean "default" (define task-sema (make-semaphore 1)) @@ -254,7 +255,10 @@ ;; Check results: (when check-stderr? - (unless (equal? #"" (get-output-bytes e)) + (unless (let ([s (get-output-bytes e)]) + (or (equal? #"" s) + (ormap (lambda (p) (regexp-match? p s)) + ignore-stderr-patterns))) (error 'test "non-empty stderr: ~e" (get-output-bytes e)))) (unless (zero? result-code) (error 'test "non-zero exit: ~e" result-code)) @@ -913,15 +917,21 @@ [("--fresh-user") "Fresh PLTUSERHOME, etc., for each test" (set! fresh-user? #t)] + [("--empty-stdin") + "Call program with an empty stdin" + (set! empty-input? #t)] [("--quiet-program" "-Q") "Quiet the program" (set! quiet-program? #t)] [("--check-stderr" "-e") "Treat stderr output as a test failure" (set! check-stderr? #t)] - [("--empty-stdin") - "Call program with an empty stdin" - (set! empty-input? #t)] + #:multi + [("++ignore-stderr") pattern + "Ignore standard error output if it matches #px\"\"" + (set! ignore-stderr-patterns + (cons (pregexp pattern) ignore-stderr-patterns))] + #:once-each [("--quiet" "-q") "Suppress `raco test: ...' message" (set! quiet? #t)] From 4e8f41dcaf47c84b2f086d580fda352db10ba6a3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Jun 2014 09:09:13 +0100 Subject: [PATCH 376/466] raco exe: adjust tests to avoid "stdout" in source directory original commit: 0b5fbc17c9c8b6af6ea7bf986d32a160b9d27aa0 --- .../compiler-test/tests/compiler/embed/embed-me1.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me10.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me11-rd.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me12-rd.ss | 2 +- .../compiler-test/tests/compiler/embed/embed-me14.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me15.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me16.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me17a.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me18.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me19.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me1b.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me1c.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me1d.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me1e.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me1f.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me2.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me20.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me21.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me3.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me5.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me6.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me6b.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-me9.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt | 2 +- .../tests/compiler/embed/embed-planet-1/dyn-sub.rkt | 2 +- .../tests/compiler/embed/embed-planet-1/main.rkt | 2 +- .../tests/compiler/embed/embed-planet-1/other.rkt | 2 +- .../compiler-test/tests/compiler/embed/embed-planet-2/main.ss | 2 +- .../tests/compiler/embed/embed-planet-2/private/sub.rkt | 2 +- .../compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt | 4 ++-- 30 files changed, 31 insertions(+), 31 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt index 65f7030bb1..c7cf7b2bfb 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt @@ -1,5 +1,5 @@ (module embed-me1 mzscheme - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 1\n")) 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt index 70360977d6..7ba6b48b13 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt @@ -1,7 +1,7 @@ (module embed-me10 mzscheme (require openssl/mzssl) - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "~a\n" ssl-available?)) 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt index 682396a20b..ad91d873e7 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt @@ -4,7 +4,7 @@ (define (*read port) `(module embed-me11 mzscheme - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf ,(read port) ;; Use `getenv' at read time!!! diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss index 682396a20b..ad91d873e7 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss @@ -4,7 +4,7 @@ (define (*read port) `(module embed-me11 mzscheme - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf ,(read port) ;; Use `getenv' at read time!!! diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt index 0de4c9e9a2..21987b423f 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt @@ -1,5 +1,5 @@ #lang racket/base (require "embed-me13.rkt") -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 14\n")) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt index d8107232ec..ebd9f5d9c9 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt @@ -1,5 +1,5 @@ #lang racket/base (require (submod "embed-me15-one.rkt" one)) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is ~a.\n" (+ 9 one two three))) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt index 3b109f622f..6bb9de67b3 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt @@ -2,6 +2,6 @@ ;; a `main' submodule: (module main racket/base - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 16.\n")) #:exists 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt index a6826d7597..6f61620ea8 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt @@ -4,6 +4,6 @@ (lambda () (printf "This is 17.\n"))) (module+ sub - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") print-17 #:exists 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt index f169efab51..b8fd250173 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt @@ -1,5 +1,5 @@ #lang racket/base (require (submod tests/compiler/embed/embed-me18a sub)) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (dynamic-require '(submod tests/compiler/embed/embed-me18a sub) 'print-18) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt index fcfda97e66..addc967a4e 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt @@ -9,6 +9,6 @@ (namespace-require 'racket/base) (eval (read (open-input-string "#lang plai 10")))) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 19.\n")) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt index 5c2ae8fce6..6344f44446 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt @@ -3,7 +3,7 @@ (require scheme/runtime-path (for-syntax scheme/base)) (define-runtime-path file '(lib "icons/file.gif")) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 1b\n")) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt index 70c8a943c8..d08dd0b4ee 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt @@ -3,7 +3,7 @@ (require scheme/runtime-path (for-syntax scheme/base)) (define-runtime-path file '(lib "etc.ss")) ; in mzlib -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 1c\n")) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt index 7bc3cd2149..3847ca2c43 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt @@ -3,6 +3,6 @@ (require scheme/runtime-path (for-syntax scheme/base)) (define-runtime-path file '(lib "file.gif" "icons")) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 1d\n")) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt index 8ad79cff45..1942a29e6f 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt @@ -3,6 +3,6 @@ (require scheme/runtime-path (for-syntax scheme/base)) (define-runtime-path file '(lib "html")) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 1e\n")) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt index 124a44cb48..ef2d99ed30 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt @@ -6,7 +6,7 @@ (define-runtime-path f1 "embed-me1f1.rktl") (define-runtime-path f2 "sub/embed-me1f2.rktl") -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (parameterize ([current-namespace (make-base-namespace)]) (load f1))) #:exists 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt index 0e4d9481dd..232c0a8c4d 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt @@ -1,6 +1,6 @@ (module embed-me2 mzscheme (require "embed-me1.ss" mzlib/etc) - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 2: ~a\n" true)) 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt index d4b8fe1586..f0851e8134 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt @@ -2,6 +2,6 @@ ;; like "embed-me16.rkt" using `module+' (module+ main - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 20.\n")) #:exists 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt index dbf09c11cb..856fd11230 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt @@ -7,6 +7,6 @@ (match "x" [(pregexp "x") - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 21.\n")) #:exists 'append)]) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt index 247292131a..d34cde4dc6 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt @@ -1,6 +1,6 @@ (module embed-me3 mzscheme (require mzlib/etc) - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "3 is here, too? ~a\n" true)) 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt index 23c1fbe875..f78a77d77a 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt @@ -1,6 +1,6 @@ (module embed-me5 mzscheme (require mred) - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 5: ~s\n" button%)) 'append)) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt index 58a244aee1..8cc774ae89 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt @@ -1,5 +1,5 @@ (module embed-me6 mzscheme - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 6\n") (with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))]) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt index 839af8e0b3..c2643bf99b 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt @@ -1,5 +1,5 @@ (module embed-me6b racket/base - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "This is 6\n") (with-handlers ([void (lambda (exn) (printf "no etc.ss\n"))]) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt index cdb4847278..f9aabb24b5 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt @@ -1,6 +1,6 @@ (module embed-me9 mzscheme (require "embed-me8.ss") - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf "~a\n" (ex))) 'append) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt index abb8992b46..68008701f7 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt @@ -1,6 +1,6 @@ #lang racket/base (require "main.rkt") -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") #:exists 'append (lambda () (displayln "alt"))) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt index 081b7ffd4e..e3f8034168 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt @@ -1,7 +1,7 @@ #lang racket/base (require (submod (planet racket-tester/p1/has-sub) the-sub)) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") #:exists 'append (lambda () (displayln (dynamic-require '(submod (planet racket-tester/p1/has-sub) the-sub) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt index c2ec8174a1..550c457847 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt @@ -1,4 +1,4 @@ #lang racket/base -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (displayln "one"))) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt index 98b95b7a4e..d05dfbd3d8 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (planet racket-tester/p2)) -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") #:exists 'append (lambda () (displayln "other"))) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss index 818ed55316..6874861598 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss @@ -1,5 +1,5 @@ #lang racket/base -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (displayln "two"))) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt index 120caf0483..24ff5d4162 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt @@ -1,6 +1,6 @@ #lang racket/base (require "../main.ss") -(with-output-to-file "stdout" +(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") #:exists 'append (lambda () (displayln "sub"))) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt index e2609d1f6a..4e2e6d59f1 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt @@ -219,7 +219,7 @@ (list tmp (build-path (collection-path "tests" "compiler" "embed") "embed-me4.rktl")) - `(with-output-to-file "stdout" + `(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (display "... and more!\n")) 'append) `(,(flags "l") ,(string-append "tests/compiler/embed/" filename))) @@ -256,7 +256,7 @@ '(begin (require scheme/base) (eval '(define (out s) - (with-output-to-file "stdout" + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") (lambda () (printf s)) #:exists 'append))) (out "\uA9, \u7238, and \U1D670\n"))) From 7117fd4e2c6265fbc879e2108d61aecb93835a54 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Jun 2014 09:20:17 +0100 Subject: [PATCH 377/466] raco test: fix `--process` without `--fresh-user` original commit: 85c8f271cbf680be346e97cec51a0e37f41c5291 --- .../compiler-lib/compiler/commands/test.rkt | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 8424525255..3e2ef53751 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -208,15 +208,16 @@ [current-custodian c] [current-environment-variables (environment-variables-copy (current-environment-variables))]) - (environment-variables-set! (current-environment-variables) - #"PLTUSERHOME" - (path->bytes tmp-dir)) - (environment-variables-set! (current-environment-variables) - #"TMPDIR" - (path->bytes tmp-dir)) - (environment-variables-set! (current-environment-variables) - #"PLTADDONDIR" - (path->bytes (find-system-path 'addon-dir))) + (when fresh-user? + (environment-variables-set! (current-environment-variables) + #"PLTUSERHOME" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"TMPDIR" + (path->bytes tmp-dir)) + (environment-variables-set! (current-environment-variables) + #"PLTADDONDIR" + (path->bytes (find-system-path 'addon-dir)))) (apply process*/ports stdout stdin From 9e0e4327f1b2a64db686b72ea82552af0e99b2d5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Jun 2014 09:55:48 +0100 Subject: [PATCH 378/466] raco test: continue when checking for submodules fails original commit: 94a5b02886e9aa155d06f675ac7fe6405bf16627 --- .../compiler-lib/compiler/commands/test.rkt | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 3e2ef53751..9c4a04bd6a 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -572,9 +572,19 @@ (cond [(and did-one? first-avail?) #f] - [(module-declared? mod #t) - (set! did-one? #t) - (test-this-module mod #t)] + [(with-handlers ([exn:fail? + (lambda (exn) + ;; If there's an error, then try running + ;; this submodule to let the error show. + ;; Log a warning, just in case. + (log-warning "submodule load failed: ~s" + (exn-message exn)) + 'error)]) + (and (module-declared? mod #t) + 'ok)) + => (lambda (mode) + (set! did-one? #t) + (test-this-module mod (eq? mode 'ok)))] [else (set! something-wasnt-declared? #t) #f])) From eba91e16bd3dc74812b1eeeaeb5e06f283fda7ac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 3 Jun 2014 11:35:48 +0100 Subject: [PATCH 379/466] raco test: refine override-"info.rkt" behavior of specifying a file In consultation with Jay, unify the ignore-file's-extension and ignore-"info.rkt"-disabling treatment of `raco test` arguments. The change is that the latter applies only when an argument is a file, and not when it's a directory. original commit: 1715a50c80d0bc07092d8ab05ee4812cb7cad399 --- .../compiler-lib/compiler/commands/test.rkt | 39 ++++++++++++------- 1 file changed, 24 insertions(+), 15 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 9c4a04bd6a..36e13d49cf 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -533,11 +533,12 @@ [(and (file-exists? p) (or (not check-suffix?) (regexp-match rx:default-suffixes p) - (get-cmdline p #f)) - (or explicit-arguments? - (begin (check-info p) - (not (omit-path? p))))) - ;; The above `omit-path?` loads "info.rkt" files + (get-cmdline p #f #:check-info? #t)) + (or (not check-suffix?) + (not (omit-path? p #:check-info? #t)))) + (unless check-suffix? + ;; make sure "info.rkt" information is loaded: + (check-info p)) (define norm-p (normalize-info-path p)) (define args (get-cmdline norm-p)) (define timeout (get-timeout norm-p)) @@ -657,7 +658,6 @@ (require (submod "." paths)) (define collections? #f) -(define explicit-arguments? #f) (define packages? #f) (define libraries? #f) (define check-top-suffix? #f) @@ -806,21 +806,30 @@ (define (normalize-info-path p) (simplify-path (path->complete-path p) #f)) -(define (omit-path? p) +(define (omit-path? p #:check-info? [check-info? #f]) + (when check-info? (check-info p)) (let ([p (normalize-info-path p)]) (or (hash-ref omit-paths p #f) (let-values ([(base name dir?) (split-path p)]) (and (path? base) (omit-path? base)))))) -(define (get-cmdline p [default null]) - (hash-ref command-line-arguments p default)) +(define (get-cmdline p [default null] #:check-info? [check-info? #f]) + (when check-info? (check-info p)) + (hash-ref command-line-arguments + (if check-info? (normalize-info-path p) p) + default)) -(define (get-timeout p) (hash-ref timeouts p +inf.0)) +(define (get-timeout p) + ;; assumes `(check-info p)` has been called and `p` is normalized + (hash-ref timeouts p +inf.0)) -(define (get-lock-name p) (hash-ref lock-names p #f)) +(define (get-lock-name p) + ;; assumes `(check-info p)` has been called and `p` is normalized + (hash-ref lock-names p #f)) (define (get-responsible p) + ;; assumes `(check-info p)` has been called and `p` is normalized (or (let loop ([p p]) (or (hash-ref responsibles p #f) (let-values ([(base name dir?) (split-path p)]) @@ -840,7 +849,9 @@ (and (ok-responsible? v) v)))))))) -(define (get-random p) (hash-ref randoms p #f)) +(define (get-random p) + ;; assumes `(check-info p)` has been called and `p` is normalized + (hash-ref randoms p #f)) (define (ok-responsible? v) (or (string? v) @@ -950,9 +961,7 @@ "Print a summary table" (set! table? #t)] #:args file-or-directory - (begin (set! explicit-arguments? - (not (or collections? libraries? packages? check-top-suffix?))) - (unless (= 1 (length file-or-directory)) + (begin (unless (= 1 (length file-or-directory)) (set! single-file? #f)) (define sum ;; The #:sema argument everywhre makes tests start From 52ac9d616eb008741cd5ac28ad0603c983d19913 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Jun 2014 14:59:09 +0100 Subject: [PATCH 380/466] raco test: handling of spurious files A `--drdr` run shouldn't stop because a discoevered file disappears (such as one generated temporarily by a test). Also, use new style for some errors. original commit: 034acfa5144fac1cddb0ea02c0c83ebd8ec6358f --- .../compiler-lib/compiler/commands/test.rkt | 45 ++++++++++++------- 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 36e13d49cf..d828bfa479 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -48,6 +48,8 @@ n)) (* 4 60 60))) ; default: wait at most 4 hours +(define test-exe-name (string->symbol (short-program+command-name))) + ;; Stub for running a test in a process: (module process racket/base (require rackunit/log @@ -169,9 +171,9 @@ (set! done? #t))))) (unless (thread? (sync/timeout timeout t)) (set! timeout? #t) - (error 'test "timeout after ~a seconds" timeout)) + (error test-exe-name "timeout after ~a seconds" timeout)) (unless done? - (error 'test "test raised an exception")) + (error test-exe-name "test raised an exception")) (define post (test-log #:display? #f #:exit? #f)) (values 0 (cons (- (car post) (car pre)) @@ -192,7 +194,7 @@ ;; Wait for the place to finish: (unless (sync/timeout timeout (place-dead-evt pl)) (set! timeout? #t) - (error 'test "timeout after ~a seconds" timeout)) + (error test-exe-name "timeout after ~a seconds" timeout)) ;; Get result code and test results: (values (place-wait pl) @@ -235,7 +237,7 @@ (unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) (set! timeout? #t) - (error 'test "timeout after ~a seconds" timeout)) + (error test-exe-name "timeout after ~a seconds" timeout)) (define results (with-handlers ([exn:fail:read? (lambda () #f)]) @@ -260,9 +262,9 @@ (or (equal? #"" s) (ormap (lambda (p) (regexp-match? p s)) ignore-stderr-patterns))) - (error 'test "non-empty stderr: ~e" (get-output-bytes e)))) + (error test-exe-name "non-empty stderr: ~e" (get-output-bytes e)))) (unless (zero? result-code) - (error 'test "non-zero exit: ~e" result-code)) + (error test-exe-name "non-zero exit: ~e" result-code)) (cond [test-results (summary (car test-results) (cdr test-results) (current-label) #f 0)] @@ -276,7 +278,7 @@ (build-path lock-file-dir lock-name) 'exclusive go - (lambda () (error 'test "could not obtain lock: ~s" lock-name))) + (lambda () (error test-exe-name "could not obtain lock: ~s" lock-name))) (go)))) ;; For recording stderr while also propagating to the original stderr: @@ -311,7 +313,7 @@ (define (add-submod mod sm) (if (and (pair? mod) (eq? 'submod (car mod))) (append mod '(config)) - (error 'test "cannot add test-config submodule to path: ~s" mod))) + (error test-exe-name "cannot add test-config submodule to path: ~s" mod))) (define (dynamic-require* p d #:id id @@ -530,8 +532,7 @@ #:sema s)) (directory-list p) #:sema continue-sema)))] - [(and (file-exists? p) - (or (not check-suffix?) + [(and (or (not check-suffix?) (regexp-match rx:default-suffixes p) (get-cmdline p #f #:check-info? #t)) (or (not check-suffix?) @@ -592,8 +593,6 @@ (list (and (and run-anyways? something-wasnt-declared?) (test-this-module file-name #f))))))))] - [(not (file-exists? p)) - (error 'test "given path ~e does not exist" p)] [else (summary 0 0 #f null 0)])])) (module paths racket/base @@ -669,7 +668,10 @@ [collections? (match (collection-paths e) [(list) - (error 'test "Collection ~e is not installed" e)] + (error test-exe-name + (string-append "collection not found\n" + " collection name: ~a") + e)] [l (with-summary `(collection ,e) @@ -680,7 +682,11 @@ (define p (resolved-module-path-name rmp)) (and (file-exists? p) p)) (match (find (string->symbol e)) - [#f (error 'test "Library ~e does not exist" e)] + [#f + (error test-exe-name + (string-append "module not found\n" + " module path: ~a") + e)] [l (with-summary `(library ,l) @@ -691,8 +697,17 @@ (with-summary `(package ,e) (test-files pd #:sema continue-sema)) - (error 'test "Package ~e is not installed" e))] + (error test-exe-name + (string-append "no such installed package\n" + " package name: ~a") + e))] [else + (unless (or (file-exists? e) + (directory-exists? e)) + (error test-exe-name + (string-append "no such file or directory\n" + " path: ~a") + e)) (test-files e #:check-suffix? check-suffix? #:sema continue-sema)])) From 60fe855cf792ec6d60eaa36a9b48301f7e3185ec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Jun 2014 15:23:42 +0100 Subject: [PATCH 381/466] raco test: add `--heartbeat` flag Useful when running many tests in parallel to keep track of a test that is running especially long (and maybe stuck). original commit: f3c8638366edc86683336a1ed021da86b4d14458 --- .../compiler-lib/compiler/commands/test.rkt | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index d828bfa479..58de9608bc 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -31,6 +31,7 @@ (define table? #f) (define fresh-user? #f) (define empty-input? #f) +(define heartbeat-secs #f) (define ignore-stderr-patterns null) (define jobs 0) ; 0 mean "default" @@ -490,6 +491,24 @@ (format " ~s" (format "~a" a))))) (flush-output)) id))) + (define heartbeat-sema (make-semaphore)) + (define heartbeat-t + (and heartbeat-secs + (thread (lambda () + (let loop () + (unless (sync/timeout heartbeat-secs heartbeat-sema) + (call-with-semaphore + ids-lock + (lambda () + (printf "raco test: ~a[still on ~s]\n" + (if (jobs . <= . 1) + "" + (format "~a " id)) + (let ([m (normalize-module-path p)]) + (if (and (pair? mod) (eq? 'submod (car mod))) + (list* 'submod m (cddr mod)) + m))))) + (loop))))))) (begin0 (dynamic-require* mod 0 #:id (if (jobs . <= . 1) @@ -501,6 +520,9 @@ #:responsible responsible #:lock-name lock-name #:random? random?) + (when heartbeat-t + (semaphore-post heartbeat-sema) + (sync heartbeat-t)) (call-with-semaphore ids-lock (lambda () @@ -972,6 +994,9 @@ [("--quiet" "-q") "Suppress `raco test: ...' message" (set! quiet? #t)] + [("--heartbeat") + "Periodically report that a test is still running" + (set! heartbeat-secs 5)] [("--table" "-t") "Print a summary table" (set! table? #t)] From 0c9af219db37b3c6b74d795caa2543c3d7314c62 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Jun 2014 10:17:03 +0100 Subject: [PATCH 382/466] raco test: add history note on `--heartbeat` Should have been included with f3c8638366. original commit: 2d3da47447bd91849c8e8e1981cb8f47278dade7 --- pkgs/compiler-pkgs/compiler-lib/info.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/pkgs/compiler-pkgs/compiler-lib/info.rkt b/pkgs/compiler-pkgs/compiler-lib/info.rkt index 788fe59901..bf1b6b2569 100644 --- a/pkgs/compiler-pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/info.rkt @@ -9,3 +9,5 @@ (define pkg-desc "implementation (no documentation) part of \"compiler\"") (define pkg-authors '(mflatt)) + +(define version "1.1") From c66558badb458215e195eb8e863e3f820c0e57c4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 1 Jul 2014 11:24:35 +0100 Subject: [PATCH 383/466] raco setup / raco pkg install: add `--fail-fast` flag This flag is useful for speculative package installations runs where we'd like to give up and try something else if it's not working. Specifically, we might try installing multiple packages at once, and then back off to a smaller subset if something goes wrong. original commit: d316652160a6762df37f7e5dba1f43162adbe161 --- pkgs/compiler-pkgs/compiler-lib/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/info.rkt b/pkgs/compiler-pkgs/compiler-lib/info.rkt index bf1b6b2569..d45f961b06 100644 --- a/pkgs/compiler-pkgs/compiler-lib/info.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/info.rkt @@ -10,4 +10,4 @@ (define pkg-authors '(mflatt)) -(define version "1.1") +(define version "1.2") From 9ac14af3fcdb204a20da027bba0ae2103f8dddd8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 10 Jul 2014 06:57:42 +0100 Subject: [PATCH 384/466] fix guard on references to unsafe functions in bytecode The protection against unsafe-function references was designed for bytecode that referred to unsafe operations indirectly, and that was broken when the compiler changed to refer to unsafe functions directly in bytecode (to simplify JIT inlining bytecode optimization). Actually, the relevant code (now removed) seems to be pointless, since protected-binding checking should cover it already. Maybe something else changed, or maybe the code was not properly checked in the first place. Now, `read` rejects a bytecode stream if it contains a direct reference to an unsafe function and the code inspector is not the original code inspector. It's still possible to synthesize bytecode that contains an indirect reference, and then protected-binding checking does its job. original commit: 7ccac3c0543e59c503e73ddd1e7dba62e022a279 --- pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt index ffc49b3291..751ccea841 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt @@ -67,13 +67,10 @@ (make-compilation-top ld prefix code)])) (define (read-resolve-prefix v) - (let-values ([(v unsafe?) (if (integer? (car v)) - (values v #f) - (values (cdr v) #t))]) - (match v - [`(,i ,tv . ,sv) - ; XXX Why not leave them as vectors and change the contract? - (make-prefix i (vector->list tv) (vector->list sv))]))) + (match v + [`(,i ,tv . ,sv) + ;; XXX Why not leave them as vectors and change the contract? + (make-prefix i (vector->list tv) (vector->list sv))])) (define read-free-id-info (match-lambda From f567fe3589600e06ec29661758fa3f4b3a2ec29e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 18 Jul 2014 10:54:18 +0100 Subject: [PATCH 385/466] fix a test for `raco exe` The test failed for certain installation configurations due to a problem with the test. original commit: a881e24d4319edc7bb670795fa69d9992df397af --- .../compiler-test/tests/compiler/embed/test.rkt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt index 4e2e6d59f1..62afaaffea 100644 --- a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt @@ -425,7 +425,13 @@ (parameterize ([current-error-port (open-output-nowhere)]) (test #f system* (mk-dest mred?)))) (check-collection-path "embed-me6b.rkt" "racket/fixnum.rkt" #t) - (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" #f) + (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" + ;; "mzlib" is found via the "collects" path + ;; if it is accessible via the default + ;; collection-links configuration: + (file-exists? (build-path + (find-collects-dir) + "../share/pkgs/compatibility-lib/mzlib/etc.rkt"))) (void))) From 8353db2882143e7238b8d7a37b11aed4dd32d523 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 23 Jul 2014 15:49:31 +0100 Subject: [PATCH 386/466] raco decompile: show `provide`s original commit: bf748a03c90f41fdacc732809443ddfcebb0ad3d --- .../compiler-lib/compiler/decompile.rkt | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt index 8f5e35bced..5acfe47c06 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt @@ -216,6 +216,27 @@ (if (null? l) null `((require ,@l)))) + (provide ,@(apply + append + (for/list ([p (in-list provides)]) + (define phase (car p)) + (define l + (for/list ([pv (in-list (append (cadr p) (caddr p)))]) + (match pv + [(struct provided (name src src-name nom-src src-phase protected?)) + (define n (if (eq? name src-name) + name + `(rename-out [,src-name ,name]))) + (if protected? + `(protect-out ,n) + n)]))) + (if (or (null? l) (eq? phase 0)) + l + `((,@(case phase + [(#f) `(for-label)] + [(1) `(for-syntax)] + [else `(for-meta ,phase)]) + ,@l)))))) ,@defns ,@(for/list ([submod (in-list pre-submodules)]) (decompile-module submod orig-stack stx-ht 'module)) From 7b7e158b5ab9c71892378bfe8a61278f266264e1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Aug 2014 16:26:09 +0100 Subject: [PATCH 387/466] add `update-implies` to package "info.rkt"s original commit: eb9cbe20bf7b4ebc1eee63e2ca079ae566ff8c05 --- pkgs/compiler-pkgs/compiler-test/info.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/pkgs/compiler-pkgs/compiler-test/info.rkt b/pkgs/compiler-pkgs/compiler-test/info.rkt index 649a868721..5b2913375c 100644 --- a/pkgs/compiler-pkgs/compiler-test/info.rkt +++ b/pkgs/compiler-pkgs/compiler-test/info.rkt @@ -15,3 +15,4 @@ "gui-lib" "htdp-lib" "plai")) +(define update-implies '("compiler-lib")) From d4adf3db45def50bbf14763360909acec5c58f11 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Oct 2014 09:23:15 -0500 Subject: [PATCH 388/466] raco test: fix `-l` original commit: 53cbb8b03a46c7476cf11e9f96849bff8a9dd667 --- pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 58de9608bc..89545079ff 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -703,7 +703,7 @@ (define rmp ((current-module-name-resolver) x #f #f #f)) (define p (resolved-module-path-name rmp)) (and (file-exists? p) p)) - (match (find (string->symbol e)) + (match (find `(lib ,e)) [#f (error test-exe-name (string-append "module not found\n" From eb109015792ae20e9d3e42aa750214bf377a91b0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Oct 2014 08:24:27 -0500 Subject: [PATCH 389/466] raco test: show more of stderr on failure original commit: 66729a447363363165e9eb82e16639fcf3e04ca8 --- pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt index 89545079ff..1c599475e1 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt @@ -263,7 +263,8 @@ (or (equal? #"" s) (ormap (lambda (p) (regexp-match? p s)) ignore-stderr-patterns))) - (error test-exe-name "non-empty stderr: ~e" (get-output-bytes e)))) + (parameterize ([error-print-width 16384]) + (error test-exe-name "non-empty stderr: ~e" (get-output-bytes e))))) (unless (zero? result-code) (error test-exe-name "non-zero exit: ~e" result-code)) (cond From 6e62de29ed05a7aef7ec4c6a34cb005ae717fefa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 27 Oct 2014 19:58:11 -0600 Subject: [PATCH 390/466] compiler/zo-marshal: allow extflonum literals original commit: 201a5f0e6f2376a530a65a1bf50ce14d35629fd4 --- pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt index 38371c54a1..c241013d04 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt @@ -11,7 +11,8 @@ racket/function racket/pretty racket/path - racket/set) + racket/set + racket/extflonum) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -965,7 +966,8 @@ [(or (? path?) ; XXX Why not use CPT_PATH? (? regexp?) (? byte-regexp?) - (? number?)) + (? number?) + (? extflonum?)) (out-byte CPT_QUOTE out) (define s (open-output-bytes)) (parameterize From b46e39d5eb4602fc3d4220c02f360872355fe167 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 9 Nov 2014 08:46:59 -0700 Subject: [PATCH 391/466] move `raco make` test to a more sensible place original commit: 28b98beb6ce48c36e0fd352e1643b7fd29b1e9b0 --- .../compiler-test/tests/compiler/make.rkt | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 pkgs/compiler-pkgs/compiler-test/tests/compiler/make.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/make.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/make.rkt new file mode 100644 index 0000000000..e537e03b4a --- /dev/null +++ b/pkgs/compiler-pkgs/compiler-test/tests/compiler/make.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require racket/file + racket/path + racket/system + compiler/find-exe) + +(define tmpdir (make-temporary-file "tmp~a" 'directory (current-directory))) +(define tmppath (build-path tmpdir "tmp.rkt")) +(with-output-to-file (build-path tmpdir "tmp.rkt") #:exists 'replace + (lambda () + (printf "#lang racket\n"))) +(define exec-path (find-exe)) +(define relpath (find-relative-path (current-directory) tmppath)) + +(define ok? (system* exec-path "-l" "raco" "make" "-j" "2" (path->string relpath))) +(delete-directory/files tmpdir) + +(unless ok? + (error "`raco make` test failed")) + From 7678d59f14599ddb04a3ae3dd5d9ea204bcaef06 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 25 Nov 2014 14:08:39 -0500 Subject: [PATCH 392/466] Remove stray reference to Racket in LICENSE files. Related to PR 14842. original commit: 3bbdd134b1754d51422eeaec1c35e9c62d45144c --- pkgs/compiler-pkgs/compiler-lib/LICENSE.txt | 2 +- pkgs/compiler-pkgs/compiler-test/LICENSE.txt | 2 +- pkgs/compiler-pkgs/compiler/LICENSE.txt | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt b/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt index ccfab19fda..e3fb23eec0 100644 --- a/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt @@ -2,7 +2,7 @@ compiler-lib Copyright (c) 2010-2014 PLT Design Inc. This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link Racket into proprietary +License (LGPL). This means that you can link this package into proprietary applications, provided you follow the rules stated in the LGPL. You can also modify this package; if you distribute a modified version, you must distribute it under the terms of the LGPL, which in diff --git a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt index d2fa970321..bf291935db 100644 --- a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler-test/LICENSE.txt @@ -2,7 +2,7 @@ compiler-test Copyright (c) 2010-2014 PLT Design Inc. This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link Racket into proprietary +License (LGPL). This means that you can link this package into proprietary applications, provided you follow the rules stated in the LGPL. You can also modify this package; if you distribute a modified version, you must distribute it under the terms of the LGPL, which in diff --git a/pkgs/compiler-pkgs/compiler/LICENSE.txt b/pkgs/compiler-pkgs/compiler/LICENSE.txt index 06aa96254b..5fdef4b767 100644 --- a/pkgs/compiler-pkgs/compiler/LICENSE.txt +++ b/pkgs/compiler-pkgs/compiler/LICENSE.txt @@ -2,7 +2,7 @@ compiler Copyright (c) 2010-2014 PLT Design Inc. This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link Racket into proprietary +License (LGPL). This means that you can link this package into proprietary applications, provided you follow the rules stated in the LGPL. You can also modify this package; if you distribute a modified version, you must distribute it under the terms of the LGPL, which in From 49ccf968d0f9317de09e46c4a872f07ca44dce56 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 2 Dec 2014 09:30:05 -0500 Subject: [PATCH 393/466] Remove extra directories. --- {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/LICENSE.txt | 0 .../compiler-lib => compiler-lib}/compiler/bundle-dist.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/decompile.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/exe-dir.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/exe.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/expand.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/info.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/make.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/pack.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/test.rkt | 0 .../compiler-lib => compiler-lib}/compiler/commands/unpack.rkt | 0 .../compiler-lib => compiler-lib}/compiler/compiler-unit.rkt | 0 .../compiler-lib => compiler-lib}/compiler/decompile.rkt | 0 .../compiler/demodularizer/alpha.rkt | 0 .../compiler/demodularizer/batch.rkt | 0 .../compiler/demodularizer/gc-toplevels.rkt | 0 .../compiler-lib => compiler-lib}/compiler/demodularizer/info.rkt | 0 .../compiler-lib => compiler-lib}/compiler/demodularizer/main.rkt | 0 .../compiler/demodularizer/merge.rkt | 0 .../compiler/demodularizer/module.rkt | 0 .../compiler-lib => compiler-lib}/compiler/demodularizer/mpi.rkt | 0 .../compiler/demodularizer/nodep.rkt | 0 .../compiler/demodularizer/replace-modidx.rkt | 0 .../compiler/demodularizer/update-toplevels.rkt | 0 .../compiler-lib => compiler-lib}/compiler/demodularizer/util.rkt | 0 .../compiler-lib => compiler-lib}/compiler/embed-sig.rkt | 0 .../compiler-lib => compiler-lib}/compiler/embed-unit.rkt | 0 .../compiler-lib => compiler-lib}/compiler/option-unit.rkt | 0 .../compiler-pkgs/compiler-lib => compiler-lib}/compiler/sig.rkt | 0 .../compiler-lib => compiler-lib}/compiler/zo-marshal.rkt | 0 .../compiler-lib => compiler-lib}/compiler/zo-parse.rkt | 0 .../compiler-lib => compiler-lib}/compiler/zo-structs.rkt | 0 {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/info.rkt | 0 .../compiler-lib => compiler-lib}/launcher/launcher-sig.rkt | 0 .../compiler-lib => compiler-lib}/launcher/launcher-unit.rkt | 0 .../compiler-lib => compiler-lib}/setup/option-sig.rkt | 0 .../compiler-lib => compiler-lib}/setup/option-unit.rkt | 0 .../compiler-lib => compiler-lib}/setup/setup-unit.rkt | 0 {pkgs/compiler-pkgs/compiler-test => compiler-test}/LICENSE.txt | 0 {pkgs/compiler-pkgs/compiler-test => compiler-test}/info.rkt | 0 .../tests/compiler/collection-zos.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/ctool.rkt | 0 .../tests/compiler/demodularizer/demod-test.rkt | 0 .../tests/compiler/demodularizer/tests/base-5.rkt | 0 .../tests/compiler/demodularizer/tests/kernel-5.rkt | 0 .../tests/compiler/demodularizer/tests/racket-5.rkt | 0 .../tests/compiler/embed/embed-asl.rkt | 0 .../tests/compiler/embed/embed-bsl.rkt | 0 .../tests/compiler/embed/embed-bsla.rkt | 0 .../tests/compiler/embed/embed-isl.rkt | 0 .../tests/compiler/embed/embed-isll.rkt | 0 .../tests/compiler/embed/embed-me1.rkt | 0 .../tests/compiler/embed/embed-me10.rkt | 0 .../tests/compiler/embed/embed-me11-rd.rkt | 0 .../tests/compiler/embed/embed-me11.rkt | 0 .../tests/compiler/embed/embed-me12-rd.ss | 0 .../tests/compiler/embed/embed-me12.ss | 0 .../tests/compiler/embed/embed-me13.rkt | 0 .../tests/compiler/embed/embed-me14.rkt | 0 .../tests/compiler/embed/embed-me15-one.rkt | 0 .../tests/compiler/embed/embed-me15.rkt | 0 .../tests/compiler/embed/embed-me16.rkt | 0 .../tests/compiler/embed/embed-me17.rkt | 0 .../tests/compiler/embed/embed-me17a.rkt | 0 .../tests/compiler/embed/embed-me18.rkt | 0 .../tests/compiler/embed/embed-me18a.rkt | 0 .../tests/compiler/embed/embed-me19.rkt | 0 .../tests/compiler/embed/embed-me1b.rkt | 0 .../tests/compiler/embed/embed-me1c.rkt | 0 .../tests/compiler/embed/embed-me1d.rkt | 0 .../tests/compiler/embed/embed-me1e.rkt | 0 .../tests/compiler/embed/embed-me1f.rkt | 0 .../tests/compiler/embed/embed-me1f1.rktl | 0 .../tests/compiler/embed/embed-me2.rkt | 0 .../tests/compiler/embed/embed-me20.rkt | 0 .../tests/compiler/embed/embed-me21.rkt | 0 .../tests/compiler/embed/embed-me22.rkt | 0 .../tests/compiler/embed/embed-me23.rkt | 0 .../tests/compiler/embed/embed-me24.rkt | 0 .../tests/compiler/embed/embed-me3.rkt | 0 .../tests/compiler/embed/embed-me4.rktl | 0 .../tests/compiler/embed/embed-me5.rkt | 0 .../tests/compiler/embed/embed-me6.rkt | 0 .../tests/compiler/embed/embed-me6b.rkt | 0 .../tests/compiler/embed/embed-me8.c | 0 .../tests/compiler/embed/embed-me9.rkt | 0 .../tests/compiler/embed/embed-place.rkt | 0 .../tests/compiler/embed/embed-planet-1/alt.rkt | 0 .../tests/compiler/embed/embed-planet-1/dyn-sub.rkt | 0 .../tests/compiler/embed/embed-planet-1/has-sub.rkt | 0 .../tests/compiler/embed/embed-planet-1/main.rkt | 0 .../tests/compiler/embed/embed-planet-1/other.rkt | 0 .../tests/compiler/embed/embed-planet-2/main.ss | 0 .../tests/compiler/embed/embed-planet-2/private/sub.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/embed/info.rkt | 0 .../tests/compiler/embed/sub/embed-me1f2.rktl | 0 .../compiler-test => compiler-test}/tests/compiler/embed/test.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/info.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/make.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/regression.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/test/a.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/test/b.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/test/d/c.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/test/d/d.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/zo-exs.rkt | 0 .../tests/compiler/zo-test-util.rkt | 0 .../tests/compiler/zo-test-worker.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/zo-test.rkt | 0 .../compiler-test => compiler-test}/tests/compiler/zo.rkt | 0 {pkgs/compiler-pkgs/compiler => compiler}/LICENSE.txt | 0 {pkgs/compiler-pkgs/compiler => compiler}/info.rkt | 0 111 files changed, 0 insertions(+), 0 deletions(-) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/LICENSE.txt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/bundle-dist.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/decompile.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/exe-dir.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/exe.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/expand.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/info.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/make.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/pack.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/test.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/commands/unpack.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/compiler-unit.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/decompile.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/alpha.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/batch.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/gc-toplevels.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/info.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/main.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/merge.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/module.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/mpi.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/nodep.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/replace-modidx.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/update-toplevels.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/demodularizer/util.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/embed-sig.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/embed-unit.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/option-unit.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/sig.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/zo-marshal.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/zo-parse.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/compiler/zo-structs.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/info.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/launcher/launcher-sig.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/launcher/launcher-unit.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/setup/option-sig.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/setup/option-unit.rkt (100%) rename {pkgs/compiler-pkgs/compiler-lib => compiler-lib}/setup/setup-unit.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/LICENSE.txt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/info.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/collection-zos.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/ctool.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/demodularizer/demod-test.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/demodularizer/tests/base-5.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/demodularizer/tests/kernel-5.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/demodularizer/tests/racket-5.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-asl.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-bsl.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-bsla.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-isl.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-isll.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me1.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me10.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me11-rd.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me11.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me12-rd.ss (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me12.ss (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me13.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me14.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me15-one.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me15.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me16.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me17.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me17a.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me18.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me18a.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me19.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me1b.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me1c.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me1d.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me1e.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me1f.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me1f1.rktl (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me2.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me20.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me21.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me22.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me23.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me24.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me3.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me4.rktl (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me5.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me6.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me6b.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me8.c (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-me9.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-place.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-planet-1/alt.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-planet-1/dyn-sub.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-planet-1/has-sub.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-planet-1/main.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-planet-1/other.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-planet-2/main.ss (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/embed-planet-2/private/sub.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/info.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/sub/embed-me1f2.rktl (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/embed/test.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/info.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/make.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/regression.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/test/a.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/test/b.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/test/d/c.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/test/d/d.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/zo-exs.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/zo-test-util.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/zo-test-worker.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/zo-test.rkt (100%) rename {pkgs/compiler-pkgs/compiler-test => compiler-test}/tests/compiler/zo.rkt (100%) rename {pkgs/compiler-pkgs/compiler => compiler}/LICENSE.txt (100%) rename {pkgs/compiler-pkgs/compiler => compiler}/info.rkt (100%) diff --git a/pkgs/compiler-pkgs/compiler-lib/LICENSE.txt b/compiler-lib/LICENSE.txt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/LICENSE.txt rename to compiler-lib/LICENSE.txt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/bundle-dist.rkt b/compiler-lib/compiler/bundle-dist.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/bundle-dist.rkt rename to compiler-lib/compiler/bundle-dist.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt b/compiler-lib/compiler/commands/decompile.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/decompile.rkt rename to compiler-lib/compiler/commands/decompile.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt b/compiler-lib/compiler/commands/exe-dir.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt rename to compiler-lib/compiler/commands/exe-dir.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt b/compiler-lib/compiler/commands/exe.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt rename to compiler-lib/compiler/commands/exe.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt b/compiler-lib/compiler/commands/expand.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/expand.rkt rename to compiler-lib/compiler/commands/expand.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt b/compiler-lib/compiler/commands/info.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/info.rkt rename to compiler-lib/compiler/commands/info.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt b/compiler-lib/compiler/commands/make.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt rename to compiler-lib/compiler/commands/make.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt b/compiler-lib/compiler/commands/pack.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/pack.rkt rename to compiler-lib/compiler/commands/pack.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt rename to compiler-lib/compiler/commands/test.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/unpack.rkt b/compiler-lib/compiler/commands/unpack.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/commands/unpack.rkt rename to compiler-lib/compiler/commands/unpack.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/compiler-unit.rkt b/compiler-lib/compiler/compiler-unit.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/compiler-unit.rkt rename to compiler-lib/compiler/compiler-unit.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/decompile.rkt rename to compiler-lib/compiler/decompile.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/alpha.rkt b/compiler-lib/compiler/demodularizer/alpha.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/alpha.rkt rename to compiler-lib/compiler/demodularizer/alpha.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt b/compiler-lib/compiler/demodularizer/batch.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/batch.rkt rename to compiler-lib/compiler/demodularizer/batch.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt rename to compiler-lib/compiler/demodularizer/gc-toplevels.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/info.rkt b/compiler-lib/compiler/demodularizer/info.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/info.rkt rename to compiler-lib/compiler/demodularizer/info.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/main.rkt b/compiler-lib/compiler/demodularizer/main.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/main.rkt rename to compiler-lib/compiler/demodularizer/main.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/merge.rkt rename to compiler-lib/compiler/demodularizer/merge.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/module.rkt b/compiler-lib/compiler/demodularizer/module.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/module.rkt rename to compiler-lib/compiler/demodularizer/module.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/mpi.rkt b/compiler-lib/compiler/demodularizer/mpi.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/mpi.rkt rename to compiler-lib/compiler/demodularizer/mpi.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/nodep.rkt rename to compiler-lib/compiler/demodularizer/nodep.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt b/compiler-lib/compiler/demodularizer/replace-modidx.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt rename to compiler-lib/compiler/demodularizer/replace-modidx.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt b/compiler-lib/compiler/demodularizer/update-toplevels.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt rename to compiler-lib/compiler/demodularizer/update-toplevels.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/util.rkt b/compiler-lib/compiler/demodularizer/util.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/demodularizer/util.rkt rename to compiler-lib/compiler/demodularizer/util.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/embed-sig.rkt b/compiler-lib/compiler/embed-sig.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/embed-sig.rkt rename to compiler-lib/compiler/embed-sig.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/embed-unit.rkt b/compiler-lib/compiler/embed-unit.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/embed-unit.rkt rename to compiler-lib/compiler/embed-unit.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/option-unit.rkt b/compiler-lib/compiler/option-unit.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/option-unit.rkt rename to compiler-lib/compiler/option-unit.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/sig.rkt b/compiler-lib/compiler/sig.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/sig.rkt rename to compiler-lib/compiler/sig.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt b/compiler-lib/compiler/zo-marshal.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/zo-marshal.rkt rename to compiler-lib/compiler/zo-marshal.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt b/compiler-lib/compiler/zo-parse.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/zo-parse.rkt rename to compiler-lib/compiler/zo-parse.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/zo-structs.rkt b/compiler-lib/compiler/zo-structs.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/compiler/zo-structs.rkt rename to compiler-lib/compiler/zo-structs.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/info.rkt b/compiler-lib/info.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/info.rkt rename to compiler-lib/info.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/launcher/launcher-sig.rkt b/compiler-lib/launcher/launcher-sig.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/launcher/launcher-sig.rkt rename to compiler-lib/launcher/launcher-sig.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/launcher/launcher-unit.rkt b/compiler-lib/launcher/launcher-unit.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/launcher/launcher-unit.rkt rename to compiler-lib/launcher/launcher-unit.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/setup/option-sig.rkt b/compiler-lib/setup/option-sig.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/setup/option-sig.rkt rename to compiler-lib/setup/option-sig.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/setup/option-unit.rkt b/compiler-lib/setup/option-unit.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/setup/option-unit.rkt rename to compiler-lib/setup/option-unit.rkt diff --git a/pkgs/compiler-pkgs/compiler-lib/setup/setup-unit.rkt b/compiler-lib/setup/setup-unit.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-lib/setup/setup-unit.rkt rename to compiler-lib/setup/setup-unit.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/LICENSE.txt b/compiler-test/LICENSE.txt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/LICENSE.txt rename to compiler-test/LICENSE.txt diff --git a/pkgs/compiler-pkgs/compiler-test/info.rkt b/compiler-test/info.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/info.rkt rename to compiler-test/info.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/collection-zos.rkt b/compiler-test/tests/compiler/collection-zos.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/collection-zos.rkt rename to compiler-test/tests/compiler/collection-zos.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/ctool.rkt b/compiler-test/tests/compiler/ctool.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/ctool.rkt rename to compiler-test/tests/compiler/ctool.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt b/compiler-test/tests/compiler/demodularizer/demod-test.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt rename to compiler-test/tests/compiler/demodularizer/demod-test.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt b/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/base-5.rkt rename to compiler-test/tests/compiler/demodularizer/tests/base-5.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt b/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt rename to compiler-test/tests/compiler/demodularizer/tests/kernel-5.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt b/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt rename to compiler-test/tests/compiler/demodularizer/tests/racket-5.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-asl.rkt b/compiler-test/tests/compiler/embed/embed-asl.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-asl.rkt rename to compiler-test/tests/compiler/embed/embed-asl.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsl.rkt b/compiler-test/tests/compiler/embed/embed-bsl.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsl.rkt rename to compiler-test/tests/compiler/embed/embed-bsl.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsla.rkt b/compiler-test/tests/compiler/embed/embed-bsla.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-bsla.rkt rename to compiler-test/tests/compiler/embed/embed-bsla.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isl.rkt b/compiler-test/tests/compiler/embed/embed-isl.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isl.rkt rename to compiler-test/tests/compiler/embed/embed-isl.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isll.rkt b/compiler-test/tests/compiler/embed/embed-isll.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-isll.rkt rename to compiler-test/tests/compiler/embed/embed-isll.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt b/compiler-test/tests/compiler/embed/embed-me1.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1.rkt rename to compiler-test/tests/compiler/embed/embed-me1.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt b/compiler-test/tests/compiler/embed/embed-me10.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me10.rkt rename to compiler-test/tests/compiler/embed/embed-me10.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt b/compiler-test/tests/compiler/embed/embed-me11-rd.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11-rd.rkt rename to compiler-test/tests/compiler/embed/embed-me11-rd.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11.rkt b/compiler-test/tests/compiler/embed/embed-me11.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me11.rkt rename to compiler-test/tests/compiler/embed/embed-me11.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss b/compiler-test/tests/compiler/embed/embed-me12-rd.ss similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12-rd.ss rename to compiler-test/tests/compiler/embed/embed-me12-rd.ss diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12.ss b/compiler-test/tests/compiler/embed/embed-me12.ss similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me12.ss rename to compiler-test/tests/compiler/embed/embed-me12.ss diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me13.rkt b/compiler-test/tests/compiler/embed/embed-me13.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me13.rkt rename to compiler-test/tests/compiler/embed/embed-me13.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt b/compiler-test/tests/compiler/embed/embed-me14.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me14.rkt rename to compiler-test/tests/compiler/embed/embed-me14.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15-one.rkt b/compiler-test/tests/compiler/embed/embed-me15-one.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15-one.rkt rename to compiler-test/tests/compiler/embed/embed-me15-one.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt b/compiler-test/tests/compiler/embed/embed-me15.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me15.rkt rename to compiler-test/tests/compiler/embed/embed-me15.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt b/compiler-test/tests/compiler/embed/embed-me16.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me16.rkt rename to compiler-test/tests/compiler/embed/embed-me16.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17.rkt b/compiler-test/tests/compiler/embed/embed-me17.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17.rkt rename to compiler-test/tests/compiler/embed/embed-me17.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt b/compiler-test/tests/compiler/embed/embed-me17a.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me17a.rkt rename to compiler-test/tests/compiler/embed/embed-me17a.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt b/compiler-test/tests/compiler/embed/embed-me18.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18.rkt rename to compiler-test/tests/compiler/embed/embed-me18.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18a.rkt b/compiler-test/tests/compiler/embed/embed-me18a.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me18a.rkt rename to compiler-test/tests/compiler/embed/embed-me18a.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt b/compiler-test/tests/compiler/embed/embed-me19.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me19.rkt rename to compiler-test/tests/compiler/embed/embed-me19.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt b/compiler-test/tests/compiler/embed/embed-me1b.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1b.rkt rename to compiler-test/tests/compiler/embed/embed-me1b.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt b/compiler-test/tests/compiler/embed/embed-me1c.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1c.rkt rename to compiler-test/tests/compiler/embed/embed-me1c.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt b/compiler-test/tests/compiler/embed/embed-me1d.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1d.rkt rename to compiler-test/tests/compiler/embed/embed-me1d.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt b/compiler-test/tests/compiler/embed/embed-me1e.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1e.rkt rename to compiler-test/tests/compiler/embed/embed-me1e.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt b/compiler-test/tests/compiler/embed/embed-me1f.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f.rkt rename to compiler-test/tests/compiler/embed/embed-me1f.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f1.rktl b/compiler-test/tests/compiler/embed/embed-me1f1.rktl similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me1f1.rktl rename to compiler-test/tests/compiler/embed/embed-me1f1.rktl diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt b/compiler-test/tests/compiler/embed/embed-me2.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me2.rkt rename to compiler-test/tests/compiler/embed/embed-me2.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt b/compiler-test/tests/compiler/embed/embed-me20.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me20.rkt rename to compiler-test/tests/compiler/embed/embed-me20.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt b/compiler-test/tests/compiler/embed/embed-me21.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me21.rkt rename to compiler-test/tests/compiler/embed/embed-me21.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me22.rkt b/compiler-test/tests/compiler/embed/embed-me22.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me22.rkt rename to compiler-test/tests/compiler/embed/embed-me22.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me23.rkt b/compiler-test/tests/compiler/embed/embed-me23.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me23.rkt rename to compiler-test/tests/compiler/embed/embed-me23.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me24.rkt b/compiler-test/tests/compiler/embed/embed-me24.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me24.rkt rename to compiler-test/tests/compiler/embed/embed-me24.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt b/compiler-test/tests/compiler/embed/embed-me3.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me3.rkt rename to compiler-test/tests/compiler/embed/embed-me3.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me4.rktl b/compiler-test/tests/compiler/embed/embed-me4.rktl similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me4.rktl rename to compiler-test/tests/compiler/embed/embed-me4.rktl diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt b/compiler-test/tests/compiler/embed/embed-me5.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me5.rkt rename to compiler-test/tests/compiler/embed/embed-me5.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt b/compiler-test/tests/compiler/embed/embed-me6.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6.rkt rename to compiler-test/tests/compiler/embed/embed-me6.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt b/compiler-test/tests/compiler/embed/embed-me6b.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me6b.rkt rename to compiler-test/tests/compiler/embed/embed-me6b.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me8.c b/compiler-test/tests/compiler/embed/embed-me8.c similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me8.c rename to compiler-test/tests/compiler/embed/embed-me8.c diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt b/compiler-test/tests/compiler/embed/embed-me9.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-me9.rkt rename to compiler-test/tests/compiler/embed/embed-me9.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-place.rkt b/compiler-test/tests/compiler/embed/embed-place.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-place.rkt rename to compiler-test/tests/compiler/embed/embed-place.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt rename to compiler-test/tests/compiler/embed/embed-planet-1/alt.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt rename to compiler-test/tests/compiler/embed/embed-planet-1/dyn-sub.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt rename to compiler-test/tests/compiler/embed/embed-planet-1/has-sub.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/main.rkt rename to compiler-test/tests/compiler/embed/embed-planet-1/main.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt b/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-1/other.rkt rename to compiler-test/tests/compiler/embed/embed-planet-1/other.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss b/compiler-test/tests/compiler/embed/embed-planet-2/main.ss similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/main.ss rename to compiler-test/tests/compiler/embed/embed-planet-2/main.ss diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt b/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt rename to compiler-test/tests/compiler/embed/embed-planet-2/private/sub.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt b/compiler-test/tests/compiler/embed/info.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/info.rkt rename to compiler-test/tests/compiler/embed/info.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl b/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl rename to compiler-test/tests/compiler/embed/sub/embed-me1f2.rktl diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/embed/test.rkt rename to compiler-test/tests/compiler/embed/test.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/info.rkt b/compiler-test/tests/compiler/info.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/info.rkt rename to compiler-test/tests/compiler/info.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/make.rkt b/compiler-test/tests/compiler/make.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/make.rkt rename to compiler-test/tests/compiler/make.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/regression.rkt b/compiler-test/tests/compiler/regression.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/regression.rkt rename to compiler-test/tests/compiler/regression.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/a.rkt b/compiler-test/tests/compiler/test/a.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/test/a.rkt rename to compiler-test/tests/compiler/test/a.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/b.rkt b/compiler-test/tests/compiler/test/b.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/test/b.rkt rename to compiler-test/tests/compiler/test/b.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/c.rkt b/compiler-test/tests/compiler/test/d/c.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/c.rkt rename to compiler-test/tests/compiler/test/d/c.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/d.rkt b/compiler-test/tests/compiler/test/d/d.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/test/d/d.rkt rename to compiler-test/tests/compiler/test/d/d.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-exs.rkt b/compiler-test/tests/compiler/zo-exs.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-exs.rkt rename to compiler-test/tests/compiler/zo-exs.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-util.rkt b/compiler-test/tests/compiler/zo-test-util.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-util.rkt rename to compiler-test/tests/compiler/zo-test-util.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt b/compiler-test/tests/compiler/zo-test-worker.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test-worker.rkt rename to compiler-test/tests/compiler/zo-test-worker.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt b/compiler-test/tests/compiler/zo-test.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/zo-test.rkt rename to compiler-test/tests/compiler/zo-test.rkt diff --git a/pkgs/compiler-pkgs/compiler-test/tests/compiler/zo.rkt b/compiler-test/tests/compiler/zo.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler-test/tests/compiler/zo.rkt rename to compiler-test/tests/compiler/zo.rkt diff --git a/pkgs/compiler-pkgs/compiler/LICENSE.txt b/compiler/LICENSE.txt similarity index 100% rename from pkgs/compiler-pkgs/compiler/LICENSE.txt rename to compiler/LICENSE.txt diff --git a/pkgs/compiler-pkgs/compiler/info.rkt b/compiler/info.rkt similarity index 100% rename from pkgs/compiler-pkgs/compiler/info.rkt rename to compiler/info.rkt From acc484f146afbf57fc11ef35af71e990d69903b4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 6 Dec 2014 17:46:37 -0500 Subject: [PATCH 394/466] Add standard .gitignore file. --- .gitignore | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..a9a9f332ee --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +# Racket compiled files +compiled/ + +# common backups, autosaves, lock files, OS meta-files +*~ +\#* +.#* +.DS_Store +*.bak +TAGS From 9650129c86b2d2e7d4eebe7dbd63a117c21dcea9 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Mon, 1 Dec 2014 15:20:37 -0300 Subject: [PATCH 395/466] repair decompiler to properly reflect the `beg0` bytecode form A single expression in `beg0` is never in tail position, unlike a single expression within `begin0`. --- compiler-lib/compiler/decompile.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 5acfe47c06..470979bf45 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -425,8 +425,11 @@ `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) - `(begin0 ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack closed)))] + (if (> (length exprs) 1) + `(begin0 ,@(for/list ([expr (in-list exprs)]) + (decompile-expr expr globs stack closed))) + `(begin0 ,(decompile-expr (car exprs) globs stack closed) + (void)))] [(struct with-cont-mark (key val body)) `(with-continuation-mark ,(decompile-expr key globs stack closed) From 539c32205eb5ec76752e3bfeb611f3860e1367e9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 10 Dec 2014 09:20:05 -0500 Subject: [PATCH 396/466] Add travis build script. --- .travis.yml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000000..2eea9c82f2 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,22 @@ +language: c + +env: +- PATH=~/racket/bin:$PATH + +before_install: +- export PKG=`echo $TRAVIS_REPO_SLUG | cut -d '/' -f 2` +- echo $PKG +- curl -L -o installer.sh http://www.cs.utah.edu/plt/snapshots/current/installers/min-racket-current-x86_64-linux-precise.sh +- sh installer.sh --in-place --dest ~/racket/ + +install: +- racket -l- pkg/dirs-catalog --link --check-metadata pkgs-catalog . +- echo file://`pwd`/pkgs-catalog/ > catalog-config.txt +- raco pkg config catalogs >> catalog-config.txt +- raco pkg config --set catalogs `cat catalog-config.txt` +- raco pkg install --deps search-auto $PKG $PKG-test + +script: +- raco test -p $PKG-test + +after_script: \ No newline at end of file From f092262df7005019594f173b397d6835860bb390 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 16 Dec 2014 22:10:52 -0500 Subject: [PATCH 397/466] Split zo file handling into its own package. --- .travis.yml | 2 +- compiler-lib/info.rkt | 5 ++++- {compiler-lib => zo-lib}/compiler/zo-marshal.rkt | 0 {compiler-lib => zo-lib}/compiler/zo-parse.rkt | 0 {compiler-lib => zo-lib}/compiler/zo-structs.rkt | 8 ++++---- zo-lib/info.rkt | 11 +++++++++++ 6 files changed, 20 insertions(+), 6 deletions(-) rename {compiler-lib => zo-lib}/compiler/zo-marshal.rkt (100%) rename {compiler-lib => zo-lib}/compiler/zo-parse.rkt (100%) rename {compiler-lib => zo-lib}/compiler/zo-structs.rkt (99%) create mode 100644 zo-lib/info.rkt diff --git a/.travis.yml b/.travis.yml index 2eea9c82f2..c54fc52ad5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,7 +14,7 @@ install: - echo file://`pwd`/pkgs-catalog/ > catalog-config.txt - raco pkg config catalogs >> catalog-config.txt - raco pkg config --set catalogs `cat catalog-config.txt` -- raco pkg install --deps search-auto $PKG $PKG-test +- raco pkg install --deps search-auto $PKG-test script: - raco test -p $PKG-test diff --git a/compiler-lib/info.rkt b/compiler-lib/info.rkt index d45f961b06..255031b0cc 100644 --- a/compiler-lib/info.rkt +++ b/compiler-lib/info.rkt @@ -4,7 +4,10 @@ (define deps '("base" "scheme-lib" - "rackunit-lib")) + "rackunit-lib" + "zo-lib")) + +(define implies '("zo-lib")) (define pkg-desc "implementation (no documentation) part of \"compiler\"") diff --git a/compiler-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt similarity index 100% rename from compiler-lib/compiler/zo-marshal.rkt rename to zo-lib/compiler/zo-marshal.rkt diff --git a/compiler-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt similarity index 100% rename from compiler-lib/compiler/zo-parse.rkt rename to zo-lib/compiler/zo-parse.rkt diff --git a/compiler-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt similarity index 99% rename from compiler-lib/compiler/zo-structs.rkt rename to zo-lib/compiler/zo-structs.rkt index 52be542051..c44b8da279 100644 --- a/compiler-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require scheme/match - scheme/contract - scheme/list +#lang racket/base +(require racket/match + racket/contract + racket/list racket/set) #| Unresolved issues diff --git a/zo-lib/info.rkt b/zo-lib/info.rkt new file mode 100644 index 0000000000..b6e36644e7 --- /dev/null +++ b/zo-lib/info.rkt @@ -0,0 +1,11 @@ +#lang info + +(define collection 'multi) + +(define deps '("base")) + +(define pkg-desc "Libraries for handling zo files") + +(define pkg-authors '(mflatt)) + +(define version "1.2") From e4af0cac26321d822f0f1d17800e07027e032adf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Jan 2015 09:58:08 -0700 Subject: [PATCH 398/466] compiler/zo-marshal: fix offsets in submodule search table --- compiler-test/tests/compiler/zo.rkt | 9 ++++++++- zo-lib/compiler/zo-marshal.rkt | 10 ++++++---- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/compiler-test/tests/compiler/zo.rkt b/compiler-test/tests/compiler/zo.rkt index 5c0b885223..67f2bfa486 100644 --- a/compiler-test/tests/compiler/zo.rkt +++ b/compiler-test/tests/compiler/zo.rkt @@ -2,7 +2,8 @@ (require racket/pretty compiler/zo-parse compiler/zo-marshal - compiler/decompile) + compiler/decompile + racket/file) (define ex-mod1 '(module m racket @@ -64,6 +65,12 @@ (write c o) (let ([p (zo-parse (open-input-bytes (get-output-bytes o)))]) (let ([b (zo-marshal p)]) + ;; Check that submodule table is ok: + (parameterize ([read-accept-compiled #t] + [current-output-port (open-output-bytes)]) + (define f (make-temporary-file)) + (call-with-output-file f #:exists 'truncate (lambda (f) (display b f))) + (dynamic-require f #f)) (let ([p2 (zo-parse (open-input-bytes b))] [to-string (lambda (p) (let ([o (open-output-bytes)]) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index c241013d04..d7ae319ff7 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -85,9 +85,11 @@ (iloop (loop (car subm) accum) (cdr subm))))))) (write-bytes (int->bytes (length pre-mod-bytess)) outp) ;; Size of btree: - (define btree-size + (define header-size (+ 8 - (string-length (version)) + (string-length (version)))) + (define btree-size + (+ header-size (apply + (for/list ([mb (in-list pre-mod-bytess)]) (+ (bytes-length (mod-bytes-name-bstr mb)) 20))))) @@ -99,7 +101,7 @@ (cons (mod-bytes (mod-bytes-code-bstr mb) (mod-bytes-name-bstr mb) offset) - (loop (+ offset + (loop (+ offset (bytes-length (mod-bytes-code-bstr mb))) (cdr mod-bytess))))))) ;; Sort by name for btree order: @@ -108,7 +110,7 @@ (define right-offsets (make-vector (vector-length sorted-mod-bytess) 0)) ;; Write out btree or compute offsets: (define (write-btree write-bytes) - (let loop ([lo 0] [hi (vector-length sorted-mod-bytess)] [pos 0]) + (let loop ([lo 0] [hi (vector-length sorted-mod-bytess)] [pos header-size]) (define mid (quotient (+ lo hi) 2)) (define mb (vector-ref sorted-mod-bytess mid)) (define name-len (bytes-length (mod-bytes-name-bstr mb))) From c12902b36eee8d97cbf3dbee3d7d3856c7001457 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 5 Jan 2015 09:15:20 -0500 Subject: [PATCH 399/466] Try compiler tests with docker and NWU snapshot. --- .travis.yml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index c54fc52ad5..99c01fd2af 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,12 +1,18 @@ language: c +sudo: false + +cache: + directories: + - $HOME/.racket/download-cache + env: - PATH=~/racket/bin:$PATH before_install: - export PKG=`echo $TRAVIS_REPO_SLUG | cut -d '/' -f 2` - echo $PKG -- curl -L -o installer.sh http://www.cs.utah.edu/plt/snapshots/current/installers/min-racket-current-x86_64-linux-precise.sh +- curl -L -o installer.sh http://plt.eecs.northwestern.edu/snapshots/current/installers/min-racket-current-x86_64-linux-precise.sh - sh installer.sh --in-place --dest ~/racket/ install: @@ -15,8 +21,8 @@ install: - raco pkg config catalogs >> catalog-config.txt - raco pkg config --set catalogs `cat catalog-config.txt` - raco pkg install --deps search-auto $PKG-test +- raco pkg install --deps search-auto compiler-lib +- ls $HOME/.racket/download-cache script: - raco test -p $PKG-test - -after_script: \ No newline at end of file From fe132b0cb61e4c589db92e8778a87e5a05a7a0cc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 5 Jan 2015 10:31:18 -0500 Subject: [PATCH 400/466] Install in installation mode to fix test. --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 99c01fd2af..8958f7ab01 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,8 +20,8 @@ install: - echo file://`pwd`/pkgs-catalog/ > catalog-config.txt - raco pkg config catalogs >> catalog-config.txt - raco pkg config --set catalogs `cat catalog-config.txt` -- raco pkg install --deps search-auto $PKG-test -- raco pkg install --deps search-auto compiler-lib +- raco pkg install -i --deps search-auto $PKG-test +- raco pkg install -i --deps search-auto compiler-lib - ls $HOME/.racket/download-cache script: From 838a58ee8439edfeaaa372315692824f92547fa6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 19 Jan 2015 21:29:23 -0700 Subject: [PATCH 401/466] decompile: adjust for change use toplevel map in `lam` --- compiler-lib/compiler/decompile.rkt | 20 ++++++++++++++------ compiler-lib/info.rkt | 2 +- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 470979bf45..e4f22e5954 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -478,12 +478,20 @@ '() (list (for/list ([pos (in-set tl-map)]) - (list-ref/protect (glob-desc-vars globs) - (if (or (pos . < . (glob-desc-num-tls globs)) - (zero? (glob-desc-num-stxs globs))) - pos - (+ pos (glob-desc-num-stxs globs) 1)) - 'lam))))))) + (define tl-pos + (cond + [(or (pos . < . (glob-desc-num-tls globs)) + (zero? (glob-desc-num-stxs globs))) + pos] + [(= pos (glob-desc-num-tls globs)) + 'stx] + [else + (+ pos (glob-desc-num-stxs globs))])) + (if (eq? tl-pos 'stx) + '#%syntax + (list-ref/protect (glob-desc-vars globs) + tl-pos + 'lam)))))))) ,(decompile-expr body globs (append captures (append vars rest-vars)) diff --git a/compiler-lib/info.rkt b/compiler-lib/info.rkt index 255031b0cc..e25b0a4856 100644 --- a/compiler-lib/info.rkt +++ b/compiler-lib/info.rkt @@ -2,7 +2,7 @@ (define collection 'multi) -(define deps '("base" +(define deps '(["base" #:version "6.1.1.8"] "scheme-lib" "rackunit-lib" "zo-lib")) From f475997263b481b7475f9b7d15133025b539587e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 9 Feb 2015 17:53:27 -0700 Subject: [PATCH 402/466] compiler/zo-marshal: repair for module language info Same repair as commit bc6670c8e0 for the Racket core. --- zo-lib/compiler/zo-marshal.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index d7ae319ff7..bd39f9b896 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -1092,7 +1092,7 @@ [l (cons max-let-depth l)] [l (cons internal-context l)] ; module->namespace syntax [l (list* #f #f l)] ; obsolete `functional?' info - [l (cons lang-info l)] ; lang-info + [l (cons (protect-quote lang-info) l)] ; lang-info [l (cons (map convert-module post-submodules) l)] [l (cons (map convert-module pre-submodules) l)] [l (cons (if (memq 'cross-phase flags) #t #f) l)] From 047c8bd85ad633f7d3ac95adeb7bb1de1df9d386 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Feb 2015 10:33:05 -0700 Subject: [PATCH 403/466] Rackety --- compiler-lib/compiler/commands/make.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler-lib/compiler/commands/make.rkt b/compiler-lib/compiler/commands/make.rkt index 2724b49057..3bc0ec7ed8 100644 --- a/compiler-lib/compiler/commands/make.rkt +++ b/compiler-lib/compiler/commands/make.rkt @@ -1,5 +1,5 @@ -#lang scheme/base -(require scheme/cmdline +#lang racket/base +(require racket/cmdline raco/command-name compiler/cm compiler/compiler From 515b31ff440672012cc060c0f78b7fce1e533f3f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 27 Feb 2015 11:23:46 -0700 Subject: [PATCH 404/466] decompile: allow collapsed module path to be relative --- compiler-lib/compiler/decompile.rkt | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index e4f22e5954..d410854ee8 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -178,10 +178,7 @@ (cond [(symbol? modidx) modidx] [else - (collapse-module-path-index modidx (build-path - (or (current-load-relative-directory) - (current-directory)) - "here.rkt"))])) + (collapse-module-path-index modidx)])) (define (decompile-module mod-form orig-stack stx-ht mod-name) (match mod-form From b5ab2b66d6f6221609442583c71dad661f1871fb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 27 Feb 2015 13:27:53 -0700 Subject: [PATCH 405/466] fix `raco exe` test Fix the decision about whether "mzlib" will be found by only setting the collection path in an executable. The old test made sense only with the pre-repo-split organization. --- compiler-test/tests/compiler/embed/test.rkt | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt index 62afaaffea..ab22506563 100644 --- a/compiler-test/tests/compiler/embed/test.rkt +++ b/compiler-test/tests/compiler/embed/test.rkt @@ -5,7 +5,8 @@ racket/system racket/port launcher - compiler/distribute) + compiler/distribute + (only-in pkg/lib installed-pkg-names)) (define (test expect f/label . args) (define r (apply (if (procedure? f/label) @@ -385,8 +386,7 @@ (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) - ;; Or, it's found if we set the collection path and the config path (where the latter - ;; finds links for packages): + ;; Or, it's found if we set the collection path: (printf ">>set coll path\n") (system* mzc (if mred? "--gui-exe" "--exe") @@ -428,10 +428,11 @@ (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" ;; "mzlib" is found via the "collects" path ;; if it is accessible via the default - ;; collection-links configuration: - (file-exists? (build-path - (find-collects-dir) - "../share/pkgs/compatibility-lib/mzlib/etc.rkt"))) + ;; collection-links configuration, which is + ;; essentially the same as being in installation + ;; scope: + (member "compatibility-lib" + (installed-pkg-names #:scope 'installation))) (void))) From 44260da512e562e3762d902a5856253a1569a576 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 8 Apr 2015 10:13:54 -0500 Subject: [PATCH 406/466] fix test case count reporting for the separate processes case --- compiler-lib/compiler/commands/test.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index 1c599475e1..55b2dc4f54 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -250,8 +250,8 @@ (values (proc 'exit-code) (and (pair? results) - (exact-positive-integer? (car results)) - (exact-positive-integer? (cdr results)) + (exact-nonnegative-integer? (car results)) + (exact-nonnegative-integer? (cdr results)) results))])) ;; Shut down the place/process (usually a no-op unless it timed out): From bdddd3c80d3b402ee0708b65d10811a1dc87ce57 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 8 Apr 2015 10:16:13 -0500 Subject: [PATCH 407/466] fix test case count reporting for the place case --- compiler-lib/compiler/commands/test.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index 55b2dc4f54..d456d42711 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -96,13 +96,14 @@ ;; If the tests use `rackunit`, collect result stats: (define test-results (test-log #:display? #f #:exit? #f)) + ;; Return test results. If we don't get this far, the result ;; code of the place determines whether it the test counts as ;; successful. (place-channel-put pch ;; If the test did not use `rackunit`, claim ;; success: - (if (zero? (car test-results)) + (if (zero? (cdr test-results)) (cons 0 1) test-results)))) From e88c746c3c3e011a66d0a6b8fd45284c873e64b1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Apr 2015 15:37:10 -0600 Subject: [PATCH 408/466] raco decompile: expose syntax info saved for REPL --- compiler-lib/compiler/decompile.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index d410854ee8..7858c917ca 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -188,6 +188,11 @@ [(stack) (append '(#%modvars) orig-stack)] [(closed) (make-hasheq)]) `(,mod-name ,(if (symbol? name) name (last name)) .... + (quote internal-context + ,(if (stx? internal-context) + `(#%decode-syntax + ,(decompile-stx (stx-encoded internal-context) stx-ht)) + internal-context)) ,@(if (null? flags) '() (list `(quote ,flags))) ,@(let ([l (apply append From 6211f43b297148438987e409b64a051361179495 Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Wed, 29 Apr 2015 08:57:58 -0400 Subject: [PATCH 409/466] Fix display missing errors on travis --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index 8958f7ab01..de74dd6f7b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,6 +14,8 @@ before_install: - echo $PKG - curl -L -o installer.sh http://plt.eecs.northwestern.edu/snapshots/current/installers/min-racket-current-x86_64-linux-precise.sh - sh installer.sh --in-place --dest ~/racket/ +- "export DISPLAY=:99.0" +- "sh -e /etc/init.d/xvfb start" install: - racket -l- pkg/dirs-catalog --link --check-metadata pkgs-catalog . From 9de3f8b87f9b6dc7a68113b3cedbaaddefc44ab1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 20 May 2015 15:57:50 -0400 Subject: [PATCH 410/466] Depend on new "plai-lib" pkg. --- compiler-test/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler-test/info.rkt b/compiler-test/info.rkt index 5b2913375c..c27205bdc7 100644 --- a/compiler-test/info.rkt +++ b/compiler-test/info.rkt @@ -14,5 +14,5 @@ "compatibility-lib" "gui-lib" "htdp-lib" - "plai")) + "plai-lib")) (define update-implies '("compiler-lib")) From 2de9cf42eb9b0275d5058ecb9e1cc182d63d2f7e Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Mon, 25 May 2015 18:59:55 -0500 Subject: [PATCH 411/466] fix default timeout --- compiler-lib/compiler/commands/test.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index d456d42711..b927636c40 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -861,7 +861,7 @@ (define (get-timeout p) ;; assumes `(check-info p)` has been called and `p` is normalized - (hash-ref timeouts p +inf.0)) + (hash-ref timeouts p (or default-timeout +inf.0))) (define (get-lock-name p) ;; assumes `(check-info p)` has been called and `p` is normalized From 0acb35ddbb671ea6124277b81f8f3fd608cf5dd2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 12 Jan 2015 09:44:33 -0500 Subject: [PATCH 412/466] Try using `cover` for code coverage. --- .gitignore | 1 + .travis.yml | 2 ++ 2 files changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index a9a9f332ee..5759923293 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ compiled/ .DS_Store *.bak TAGS +coverage/ diff --git a/.travis.yml b/.travis.yml index de74dd6f7b..478923d4ac 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,7 +24,9 @@ install: - raco pkg config --set catalogs `cat catalog-config.txt` - raco pkg install -i --deps search-auto $PKG-test - raco pkg install -i --deps search-auto compiler-lib +- raco pkg install -i --deps search-auto cover - ls $HOME/.racket/download-cache script: - raco test -p $PKG-test +- raco cover -c coveralls $TRAVIS_BUILD_DIR/coverage . From 00893cbd3f9c2122adace1205758de224c5c88f8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 26 May 2015 12:17:58 -0400 Subject: [PATCH 413/466] Avoid timeouts now that raco test enforces them. --- compiler-test/tests/compiler/demodularizer/info.rkt | 3 +++ compiler-test/tests/compiler/embed/info.rkt | 2 ++ 2 files changed, 5 insertions(+) create mode 100644 compiler-test/tests/compiler/demodularizer/info.rkt diff --git a/compiler-test/tests/compiler/demodularizer/info.rkt b/compiler-test/tests/compiler/demodularizer/info.rkt new file mode 100644 index 0000000000..2e2cc3258d --- /dev/null +++ b/compiler-test/tests/compiler/demodularizer/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define test-timeouts '(("demod-test.rkt" 120))) diff --git a/compiler-test/tests/compiler/embed/info.rkt b/compiler-test/tests/compiler/embed/info.rkt index 538a0e0b38..c498742dd3 100644 --- a/compiler-test/tests/compiler/embed/info.rkt +++ b/compiler-test/tests/compiler/embed/info.rkt @@ -16,3 +16,5 @@ (define test-omit-paths '("embed-me9.rkt" "embed-planet-1" "embed-planet-2")) + +(define test-timeouts '(("test.rkt" 600))) From 3da4b863cf4b278b020d40a7989f0d9bc1f9ab1c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 3 Jun 2015 11:53:11 -0600 Subject: [PATCH 414/466] add `raco read` --- compiler-lib/compiler/commands/expand.rkt | 69 +++++++++++++---------- compiler-lib/compiler/commands/info.rkt | 1 + compiler-lib/compiler/commands/read.rkt | 4 ++ compiler-lib/info.rkt | 2 +- 4 files changed, 45 insertions(+), 31 deletions(-) create mode 100644 compiler-lib/compiler/commands/read.rkt diff --git a/compiler-lib/compiler/commands/expand.rkt b/compiler-lib/compiler/commands/expand.rkt index cb320a2a9a..dba76ae93d 100644 --- a/compiler-lib/compiler/commands/expand.rkt +++ b/compiler-lib/compiler/commands/expand.rkt @@ -1,33 +1,42 @@ #lang racket/base -(require racket/cmdline - raco/command-name - racket/pretty) -(define source-files - (command-line - #:program (short-program+command-name) - #:once-each - [("--columns" "-n") n "Format for columns" - (let ([num (string->number n)]) - (unless (exact-positive-integer? num) - (raise-user-error (string->symbol (short-program+command-name)) - "not a valid column count: ~a" n)) - (pretty-print-columns num))] - #:args source-file - source-file)) +(module expand racket/base + (require racket/cmdline + raco/command-name + racket/pretty) + + (provide show-program) + + (define (show-program expand) + (define source-files + (command-line + #:program (short-program+command-name) + #:once-each + [("--columns" "-n") n "Format for columns" + (let ([num (string->number n)]) + (unless (exact-positive-integer? num) + (raise-user-error (string->symbol (short-program+command-name)) + "not a valid column count: ~a" n)) + (pretty-print-columns num))] + #:args source-file + source-file)) -(for ([src-file source-files]) - (let ([src-file (path->complete-path src-file)]) - (let-values ([(base name dir?) (split-path src-file)]) - (parameterize ([current-load-relative-directory base] - [current-namespace (make-base-namespace)] - [read-accept-reader #t]) - (call-with-input-file* - src-file - (lambda (in) - (port-count-lines! in) - (let loop () - (let ([e (read-syntax src-file in)]) - (unless (eof-object? e) - (pretty-write (syntax->datum (expand e))) - (loop)))))))))) + (for ([src-file source-files]) + (let ([src-file (path->complete-path src-file)]) + (let-values ([(base name dir?) (split-path src-file)]) + (parameterize ([current-load-relative-directory base] + [current-namespace (make-base-namespace)] + [read-accept-reader #t]) + (call-with-input-file* + src-file + (lambda (in) + (port-count-lines! in) + (let loop () + (let ([e (read-syntax src-file in)]) + (unless (eof-object? e) + (pretty-write (syntax->datum (expand e))) + (loop)))))))))))) + +(require (submod "." expand)) +(show-program expand) + diff --git a/compiler-lib/compiler/commands/info.rkt b/compiler-lib/compiler/commands/info.rkt index b7f1ac48d0..d8f9753937 100644 --- a/compiler-lib/compiler/commands/info.rkt +++ b/compiler-lib/compiler/commands/info.rkt @@ -8,6 +8,7 @@ ("decompile" compiler/commands/decompile "decompile bytecode" #f) ("test" compiler/commands/test "run tests associated with files/directories" 15) ("expand" compiler/commands/expand "macro-expand source" #f) + ("read" compiler/commands/read "read and pretty-print source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f))) diff --git a/compiler-lib/compiler/commands/read.rkt b/compiler-lib/compiler/commands/read.rkt new file mode 100644 index 0000000000..2f18e3530e --- /dev/null +++ b/compiler-lib/compiler/commands/read.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require (submod "expand.rkt" expand)) + +(show-program (lambda (e) e)) diff --git a/compiler-lib/info.rkt b/compiler-lib/info.rkt index e25b0a4856..f83bb4e6cb 100644 --- a/compiler-lib/info.rkt +++ b/compiler-lib/info.rkt @@ -13,4 +13,4 @@ (define pkg-authors '(mflatt)) -(define version "1.2") +(define version "1.3") From 86a410dc0c75fc8275c52f64618448abcd12f14a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Feb 2015 10:09:56 -0700 Subject: [PATCH 415/466] adjust for new syntax-object representation and marshaling --- compiler-lib/compiler/decompile.rkt | 41 +--- zo-lib/compiler/zo-parse.rkt | 289 +++++++++++----------------- zo-lib/compiler/zo-structs.rkt | 2 +- 3 files changed, 119 insertions(+), 213 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 7858c917ca..d32584605d 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -141,39 +141,9 @@ [(box? datum) (box (decompile-stx (unbox datum) stx-ht))] [else datum]) - (let loop ([wraps wraps]) - (cond - [(null? wraps) null] - [else - (or (hash-ref stx-ht wraps #f) - (let ([p (mcons #f #f)]) - (hash-set! stx-ht wraps p) - (set-mcar! p (decompile-wrap (car wraps) stx-ht)) - (set-mcdr! p (loop (cdr wraps))) - p))])))) + wraps)) p])))) -(define (decompile-wrap w stx-ht) - (or (hash-ref stx-ht w #f) - (let ([v (match w - [(lexical-rename has-free-id-renames? - ignored - alist) - `(,(if has-free-id-renames? 'lexical/free-id=? 'lexical) . ,alist)] - [(phase-shift amt src dest cancel-id) - `(phase-shift ,amt ,src ,dest, cancel-id)] - [(wrap-mark val) - val] - [(prune sym) - `(prune ,sym)] - [(module-rename phase kind set-id unmarshals renames mark-renames plus-kern?) - `(module-rename ,phase ,kind ,set-id ,unmarshals ,renames ,mark-renames ,plus-kern?)] - [(top-level-rename flag) - `(top-level-rename ,flag)] - [else w])]) - (hash-set! stx-ht w v) - v))) - (define (mpi->string modidx) (cond [(symbol? modidx) modidx] @@ -352,7 +322,7 @@ [(struct topsyntax (depth pos midpt)) (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] [(struct primval (id)) - (hash-ref primitive-table id (lambda () (error "unknown primitive")))] + (hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))] [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id globs stack closed) ,(decompile-expr rhs globs stack closed))] @@ -427,11 +397,8 @@ `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) - (if (> (length exprs) 1) - `(begin0 ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack closed))) - `(begin0 ,(decompile-expr (car exprs) globs stack closed) - (void)))] + `(begin0 ,@(for/list ([expr (in-list exprs)]) + (decompile-expr expr globs stack closed)))] [(struct with-cont-mark (key val body)) `(with-continuation-mark ,(decompile-expr key globs stack closed) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 751ccea841..93887ba133 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -372,8 +372,7 @@ [(27) 'inline-variant-type] [(35) 'variable-type] [(36) 'module-variable-type] - [(114) 'resolve-prefix-type] - [(164) 'free-id-info-type] + [(115) 'resolve-prefix-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers @@ -485,8 +484,10 @@ [33 delayed] [34 prefab] [35 let-one-unused] - [36 60 small-number] - [60 80 small-symbol] + [36 mark] + [37 shared] + [38 62 small-number] + [62 80 small-symbol] [80 92 small-marshalled] [92 ,(+ 92 small-list-max) small-proper-list] [,(+ 92 small-list-max) 192 small-list] @@ -573,6 +574,7 @@ (arithmetic-shift a b)) (define-struct not-ready ()) +(define-struct in-progress ()) ;; ---------------------------------------- ;; Syntax unmarshaling @@ -582,133 +584,68 @@ (define-syntax-rule (with-memo mt arg body ...) (with-memo* mt arg (λ () body ...))) -(define (decode-mark-map alist) - alist) - -(define stx-memo (make-memo)) -; XXX More memo use (define (decode-stx cp v) - (with-memo stx-memo v - (if (integer? v) - (unmarshal-stx-get/decode cp v decode-stx) - (let loop ([v v]) - (let-values ([(tamper-status v encoded-wraps) - (match v - [`#((,datum . ,wraps)) (values 'tainted datum wraps)] - [`#((,datum . ,wraps) #f) (values 'armed datum wraps)] - [`(,datum . ,wraps) (values 'clean datum wraps)] - [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) - (let* ([wraps (decode-wraps cp encoded-wraps)] - [wrapped-memo (make-memo)] - [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps tamper-status)))]) - (cond - [(pair? v) - (if (eq? #t (car v)) - ;; Share decoded wraps with all nested parts. - (let iloop ([v (cdr v)]) - (cond - [(pair? v) - (let ploop ([v v]) - (cond - [(null? v) null] - [(pair? v) (add-wrap (cons (iloop (car v)) (ploop (cdr v))))] - [else (iloop v)]))] - [(box? v) (add-wrap (box (iloop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map iloop (vector->list v))))] - [(hash? v) - (add-wrap (for/hash ([(k v) (in-hash v)]) - (values k (iloop v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map iloop (struct->list v)))))] - [else (add-wrap v)])) - ;; Decode sub-elements that have their own wraps: - (let-values ([(v counter) (if (exact-integer? (car v)) - (values (cdr v) (car v)) - (values v -1))]) + (let loop ([v v]) + (let-values ([(tamper-status v encoded-wraps) + (match v + [`#((,datum . ,wraps)) (values 'tainted datum wraps)] + [`#((,datum . ,wraps) #f) (values 'armed datum wraps)] + [`(,datum . ,wraps) (values 'clean datum wraps)] + [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) + (let* ([wraps (decode-wraps cp encoded-wraps)] + [wrapped-memo (make-memo)] + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps tamper-status)))]) + (cond + [(pair? v) + (if (eq? #t (car v)) + ;; Share decoded wraps with all nested parts. + (let iloop ([v (cdr v)]) + (cond + [(pair? v) + (let ploop ([v v]) + (cond + [(null? v) null] + [(pair? v) (add-wrap (cons (iloop (car v)) (ploop (cdr v))))] + [else (iloop v)]))] + [(box? v) (add-wrap (box (iloop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map iloop (vector->list v))))] + [(hash? v) + (add-wrap (for/hash ([(k v) (in-hash v)]) + (values k (iloop v))))] + [(prefab-struct-key v) + => (lambda (k) (add-wrap - (let ploop ([v v][counter counter]) - (cond - [(null? v) null] - [(or (not (pair? v)) (zero? counter)) (loop v)] - [(pair? v) (cons (loop (car v)) - (ploop (cdr v) (sub1 counter)))])))))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(hash? v) - (add-wrap (for/hash ([(k v) (in-hash v)]) - (values k (loop v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)]))))))) - -(define wrape-memo (make-memo)) -(define (decode-wrape cp a) - (define (aloop a) (decode-wrape cp a)) - (with-memo wrape-memo a - ; A wrap-elem is either - (cond - ; A reference - [(integer? a) - (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] - ; A mark wraped in a list - [(and (pair? a) (number? (car a)) (null? (cdr a))) - (make-wrap-mark (car a))] - - [(vector? a) - (make-lexical-rename (vector-ref a 0) (vector-ref a 1) - (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) - (let loop ([i 2]) - (if (= i top) - null - (cons (cons (vector-ref a i) - (vector-ref a (+ (- top 2) i))) - (loop (+ i 1)))))))] - [(pair? a) - (let-values ([(plus-kern? a) (if (eq? (car a) #t) - (values #t (cdr a)) - (values #f a))]) - (match a - [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) - (let-values ([(unmarshals renames mark-renames) - (if (vector? maybe-unmarshals) - (values null maybe-unmarshals renames) - (values maybe-unmarshals - (car renames) - (cdr renames)))]) - (make-module-rename phase - (if kind 'marked 'normal) - set-id - (map (curry decode-all-from-module cp) unmarshals) - (decode-renames renames) - mark-renames - (and plus-kern? 'plus-kern)))] - [else (error "bad module rename: ~e" a)]))] - [(boolean? a) - (make-top-level-rename a)] - [(symbol? a) - (make-mark-barrier a)] - [(box? a) - (match (unbox a) - [(list (? symbol?) ...) (make-prune (unbox a))] - [`#(,amt ,src ,dest #f #f ,cancel-id) - (make-phase-shift amt - (parse-module-path-index cp src) - (parse-module-path-index cp dest) - cancel-id)] - [else (error 'parse "bad phase shift: ~e" a)])] - [else (error 'decode-wraps "bad wrap element: ~e" a)]))) + (apply + make-prefab-struct + k + (map iloop (struct->list v)))))] + [else (add-wrap v)])) + ;; Decode sub-elements that have their own wraps: + (let-values ([(v counter) (if (exact-integer? (car v)) + (values (cdr v) (car v)) + (values v -1))]) + (add-wrap + (let ploop ([v v][counter counter]) + (cond + [(null? v) null] + [(or (not (pair? v)) (zero? counter)) (loop v)] + [(pair? v) (cons (loop (car v)) + (ploop (cdr v) (sub1 counter)))])))))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(hash? v) + (add-wrap (for/hash ([(k v) (in-hash v)]) + (values k (loop v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)]))))) (define (afm-context? v) (or (and (list? v) (andmap exact-integer? v)) @@ -736,13 +673,8 @@ (parse-module-path-index cp path) phase src-phase null #f null)]))) -(define wraps-memo (make-memo)) (define (decode-wraps cp w) - (with-memo wraps-memo w - ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) - (if (integer? w) - (unmarshal-stx-get/decode cp w decode-wraps) - (map (curry decode-wrape cp) w)))) + w) (define (in-vector* v n) (make-do-sequence @@ -814,7 +746,7 @@ (case cpt-tag [(delayed) (let ([pos (read-compact-number cp)]) - (read-sym cp pos))] + (read-symref cp pos #t 'delayed))] [(escape) (let* ([len (read-compact-number cp)] [s (cport-get-bytes cp len)]) @@ -978,7 +910,7 @@ (read-compact cp)))))] [(marshalled) (read-marshalled (read-compact-number cp) cp)] [(stx) - (let ([v (make-reader-graph (read-compact cp))]) + (let ([v (read-compact cp)]) (make-stx (decode-stx cp v)))] [(local local-unbox) (let ([c (read-compact-number cp)] @@ -1024,7 +956,7 @@ (read (open-input-bytes #"x")))))] [(symref) (let* ([l (read-compact-number cp)]) - (read-sym cp l))] + (read-symref cp l #t 'symref))] [(weird-symbol) (let ([uninterned (read-compact-number cp)] [str (read-compact-chars cp (read-compact-number cp))]) @@ -1053,8 +985,11 @@ (for/list ([i (in-range c)]) (read-compact cp))))] [(closure) - (read-compact-number cp) ; symbol table pos. our marshaler will generate this - (let ([v (read-compact cp)]) + (define pos (read-compact-number cp)) + (define ph (make-placeholder 'closure)) + (symtab-write! cp pos ph) + (define v (read-compact cp)) + (define r (make-closure v (gensym @@ -1062,11 +997,21 @@ (cond [(symbol? s) s] [(vector? s) (vector-ref s 0)] - [else 'closure])))))] + [else 'closure]))))) + (placeholder-set! ph r) + r] [(svector) (read-compact-svector cp (read-compact-number cp))] [(small-svector) (read-compact-svector cp (- ch cpt-start))] + [(mark) + (let ([pos (read-compact-number cp)]) + (if (zero? pos) + (box (read-compact cp)) + (read-cyclic cp pos 'mark box)))] + [(shared) + (let ([pos (read-compact-number cp)]) + (read-cyclic cp pos 'shared))] [else (error 'read-compact "unknown tag ~a" cpt-tag)])) (cond [(zero? need-car) v] @@ -1075,40 +1020,36 @@ [else (cons v (loop (sub1 need-car) proper))]))) -(define (unmarshal-stx-get/decode cp pos decode-stx) - (define v2 (read-sym cp pos)) - (define decoded? (vector-ref (cport-decoded cp) pos)) - (if decoded? - v2 - (let ([dv2 (decode-stx cp v2)]) - (symtab-write! cp pos dv2) - (vector-set! (cport-decoded cp) pos #t) - dv2))) - (define (symtab-write! cp i v) - (placeholder-set! (vector-ref (cport-symtab cp) i) v)) + (vector-set! (cport-symtab cp) i v)) (define (symtab-lookup cp i) (vector-ref (cport-symtab cp) i)) -(require unstable/markparam) -(define read-sym-mark (mark-parameter)) -(define (read-sym cp i) - (define ph (symtab-lookup cp i)) - ; We are reading this already, so return the placeholder - (if (memq i (mark-parameter-all read-sym-mark)) - ph - ; Otherwise, try to read it and return the real thing - (let ([vv (placeholder-get ph)]) - (when (not-ready? vv) - (let ([save-pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) - (mark-parameterize - ([read-sym-mark i]) - (let ([v (read-compact cp)]) - (placeholder-set! ph v))) - (set-cport-pos! cp save-pos))) - (placeholder-get ph)))) +(define (read-cyclic cp i who [wrap values]) + (define v (symtab-lookup cp i)) + (define ph (make-placeholder (not-ready))) + (symtab-write! cp i ph) + (define r (wrap (read-compact cp))) + (when (eq? r ph) (error who "unresolvable cyclic data")) + (placeholder-set! ph r) + ph) + +(define (read-symref cp i mark-in-progress? who) + (define v (symtab-lookup cp i)) + (cond + [(not-ready? v) + (when mark-in-progress? + (symtab-write! cp i (in-progress))) + (define save-pos (cport-pos cp)) + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) + (define v (read-compact cp)) + (symtab-write! cp i v) + (set-cport-pos! cp save-pos) + v] + [(in-progress? v) + (error who "unexpected cycle in input")] + [else v])) (define (read-prefix port) ;; skip the "#~" @@ -1233,16 +1174,14 @@ (unless (eof-object? (read-byte port)) (error 'zo-parse "File too big"))) - (define nr (make-not-ready)) - (define symtab - (build-vector symtabsize (λ (i) (make-placeholder nr)))) + (define symtab (make-vector symtabsize (not-ready))) (define cp (make-cport 0 shared-size port size* rst-start symtab so* - (make-vector symtabsize #f) (make-hash) (make-hash))) + (make-vector symtabsize (not-ready)) (make-hash) (make-hash))) (for ([i (in-range 1 symtabsize)]) - (read-sym cp i)) + (read-symref cp i #f 'table)) #;(printf "Parsed table:\n") #;(for ([(i v) (in-dict (cport-symtab cp))]) diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index c44b8da279..76f05281bc 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -73,7 +73,7 @@ (define-form-struct wrap ()) (define-form-struct wrapped ([datum any/c] - [wraps (listof wrap?)] + [wraps any/c] [tamper-status (or/c 'clean 'armed 'tainted)])) ;; In stxs of prefix: From f23b6f8d464909fcee0938978808b69dd01ffc6a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 8 Mar 2015 16:06:44 -0600 Subject: [PATCH 416/466] adjustments for compiled-module content --- compiler-lib/compiler/decompile.rkt | 80 ++++++++++++++++++- compiler-lib/compiler/demodularizer/merge.rkt | 3 +- compiler-lib/compiler/demodularizer/nodep.rkt | 5 +- zo-lib/compiler/zo-marshal.rkt | 14 +++- zo-lib/compiler/zo-parse.rkt | 30 ++++++- zo-lib/compiler/zo-structs.rkt | 8 +- 6 files changed, 129 insertions(+), 11 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index d32584605d..b32d002882 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -55,11 +55,75 @@ (match top [(struct compilation-top (max-let-depth prefix form)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(begin + (expose-module-path-indexes + `(begin ,@defns - ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht)))] + ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht))))] [else (error 'decompile "unrecognized: ~e" top)]))) +(define (expose-module-path-indexes e) + ;; This is a nearly general replace-in-graph function. (It seems like a lot + ;; of work to expose module path index content and sharing, though.) + (define ht (make-hasheq)) + (define mconses null) + (define (x-mcons a b) + (define m (mcons a b)) + (set! mconses (cons (cons m (cons a b)) mconses)) + m) + (define main + (let loop ([e e]) + (cond + [(hash-ref ht e #f)] + [(module-path-index? e) + (define ph (make-placeholder #f)) + (hash-set! ht e ph) + (define-values (name base) (module-path-index-split e)) + (placeholder-set! ph (x-mcons '#%modidx + (x-mcons (loop name) + (x-mcons (loop base) + null)))) + ph] + [(pair? e) + (define ph (make-placeholder #f)) + (hash-set! ht e ph) + (placeholder-set! ph (cons (loop (car e)) + (loop (cdr e)))) + ph] + [(mpair? e) + (define m (mcons #f #f)) + (hash-set! ht e m) + (set! mconses (cons (cons m (cons (loop (mcar e)) + (loop (mcdr e)))) + mconses)) + m] + [(box? e) + (define ph (make-placeholder #f)) + (hash-set! ht e ph) + (placeholder-set! ph (box (loop (unbox e)))) + ph] + [(vector? e) + (define ph (make-placeholder #f)) + (hash-set! ht e ph) + (placeholder-set! ph + (for/vector #:length (vector-length e) ([i (in-vector e)]) + (loop i))) + ph] + [(hash? e) + (define ph (make-placeholder #f)) + (hash-set! ht e ph) + (placeholder-set! ph + (make-hash-placeholder + (for/list ([(k v) (in-hash e)]) + (cons (loop k) (loop v))))) + ph] + [else + e]))) + (define l (make-reader-graph (cons main mconses))) + (for ([i (in-list (cdr l))]) + (set-mcar! (car i) (cadr i)) + (set-mcdr! (car i) (cddr i))) + (car l)) + (define (decompile-prefix a-prefix stx-ht) (match a-prefix [(struct prefix (num-lifts toplevels stxs)) @@ -153,16 +217,26 @@ (define (decompile-module mod-form orig-stack stx-ht mod-name) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info internal-context flags pre-submodules post-submodules)) + max-let-depth dummy lang-info + internal-context binding-names + flags pre-submodules post-submodules)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [(stack) (append '(#%modvars) orig-stack)] [(closed) (make-hasheq)]) `(,mod-name ,(if (symbol? name) name (last name)) .... + (quote self ,self-modidx) (quote internal-context ,(if (stx? internal-context) `(#%decode-syntax ,(decompile-stx (stx-encoded internal-context) stx-ht)) internal-context)) + (quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)]) + (values phase + (for/hash ([(sym id) (in-hash ht)]) + (values sym + `(#%decode-syntax + ,(decompile-stx (stx-encoded id) stx-ht))))))) + (quote language-info ,lang-info) ,@(if (null? flags) '() (list `(quote ,flags))) ,@(let ([l (apply append diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt index 04de2e30a9..2bbaa5344b 100644 --- a/compiler-lib/compiler/demodularizer/merge.rkt +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -122,7 +122,8 @@ (define (merge-module max-let-depth top-prefix mod-form) (match mod-form [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies - unexported mod-max-let-depth dummy lang-info internal-context + unexported mod-max-let-depth dummy lang-info + internal-context binding-names flags pre-submodules post-submodules)) (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index 019584d076..5db811eb4b 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -140,7 +140,8 @@ (define (nodep-module mod-form phase) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies - unexported max-let-depth dummy lang-info internal-context + unexported max-let-depth dummy lang-info + internal-context binding-names flags pre-submodules post-submodules)) (define new-prefix prefix) ;; Cache all the mpi paths @@ -158,7 +159,7 @@ (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now (list (make-mod name srcname self-modidx new-prefix provides requires body empty - unexported max-let-depth dummy lang-info internal-context + unexported max-let-depth dummy lang-info internal-context #hash() empty empty empty))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index bd39f9b896..75748469ae 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -999,7 +999,9 @@ (define (convert-module mod-form) (match mod-form [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info internal-context flags pre-submodules post-submodules)) + max-let-depth dummy lang-info + internal-context binding-names + flags pre-submodules post-submodules)) (let* ([lookup-req (lambda (phase) (let ([a (assq phase requires)]) (if a @@ -1096,6 +1098,7 @@ [l (cons (map convert-module post-submodules) l)] [l (cons (map convert-module pre-submodules) l)] [l (cons (if (memq 'cross-phase flags) #t #f) l)] + [l (append (pack-binding-names binding-names) l)] [l (cons self-modidx l)] [l (cons srcname l)] [l (cons (if (pair? name) (car name) name) l)] @@ -1107,6 +1110,15 @@ (λ () (encode-wrapped w)))) +(define (pack-binding-names binding-names) + (define (ht-to-vector ht) + (list->vector (apply append (hash-map ht list)))) + (list (ht-to-vector (hash-ref binding-names 0 #f)) + (ht-to-vector (hash-ref binding-names 1 #f)) + (apply append + (for/list ([(phase ht) (in-hash binding-names)] + #:unless (or (= phase 0) (= phase 1))) + (list phase (ht-to-vector ht)))))) (define (out-lam expr out) (match expr diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 93887ba133..10a84811ce 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -248,7 +248,9 @@ (define (read-module v) (match v [`(,submod-path - ,name ,srcname ,self-modidx ,cross-phase? + ,name ,srcname ,self-modidx + ,rt-binding-names ,et-binding-names ,other-binding-names + ,cross-phase? ,pre-submods ,post-submods ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy @@ -334,15 +336,41 @@ dummy lang-info rename + (assemble-binding-names rt-binding-names + et-binding-names + other-binding-names) (if cross-phase? '(cross-phase) '()) (map read-module pre-submods) (map read-module post-submods))]))])) (define (read-module-wrap v) v) + (define (read-inline-variant v) (make-inline-variant (car v) (cdr v))) +(define (assemble-binding-names rt-binding-names + et-binding-names + other-binding-names) + (define (vector-to-ht vec) + (define sz (vector-length vec)) + (let loop ([i 0] [ht #hasheq()]) + (cond + [(= i sz) ht] + [else (loop (+ i 2) + (hash-set ht (vector-ref vec i) (vector-ref vec (add1 i))))]))) + (for/hash ([(phase vec) (let* ([ht (if other-binding-names + (vector-to-ht other-binding-names) + #hash())] + [ht (if rt-binding-names + (hash-set ht 0 rt-binding-names) + ht)] + [ht (if et-binding-names + (hash-set ht 0 et-binding-names) + ht)]) + ht)]) + (values phase (vector-to-ht vec)))) + ;; ---------------------------------------- ;; Unmarshal dispatch for various types diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index 76f05281bc..bd97241008 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -121,11 +121,11 @@ (define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))] [srcname symbol?] - [self-modidx module-path-index?] - [prefix prefix?] + [self-modidx module-path-index?] + [prefix prefix?] [provides (listof (list/c (or/c exact-integer? #f) (listof provided?) - (listof provided?)))] + (listof provided?)))] [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] [body (listof (or/c form? any/c))] @@ -138,6 +138,8 @@ [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] [internal-context (or/c #f #t stx? (vectorof stx?))] + [binding-names (hash/c exact-integer? + (hash/c symbol? stx?))] [flags (listof (or/c 'cross-phase))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) From 29d86bcaacb2ab8d41bd2c1da4551332abe164f1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 10 Mar 2015 17:21:29 -0600 Subject: [PATCH 417/466] sync with new macro system bytecode format --- zo-lib/compiler/zo-marshal.rkt | 64 ++++++++-------------------------- zo-lib/compiler/zo-parse.rkt | 11 ++---- zo-lib/compiler/zo-structs.rkt | 28 --------------- 3 files changed, 18 insertions(+), 85 deletions(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 75748469ae..a05642fa37 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -288,8 +288,7 @@ (define module-type-num 26) (define inline-variants-type-num 27) (define variable-type-num 35) -(define prefix-type-num 114) -(define free-id-info-type-num 164) +(define prefix-type-num 115) (define-syntax define-enum (syntax-rules () @@ -336,12 +335,15 @@ CPT_CLOSURE CPT_DELAY_REF ; XXX unused, but appears to be same as CPT_SYMREF CPT_PREFAB - CPT_LET_ONE_UNUSED) + CPT_LET_ONE_UNUSED + CPT_MARK + CPT_ROOT_MARK + CPT_SHARED) -(define CPT_SMALL_NUMBER_START 36) -(define CPT_SMALL_NUMBER_END 60) +(define CPT_SMALL_NUMBER_START 39) +(define CPT_SMALL_NUMBER_END 62) -(define CPT_SMALL_SYMBOL_START 60) +(define CPT_SMALL_SYMBOL_START 62) (define CPT_SMALL_SYMBOL_END 80) (define CPT_SMALL_MARSHALLED_START 80) @@ -418,39 +420,7 @@ (list* path phase src-phase exns prefix)])) (define (encode-wraps wraps) - (for/list ([wrap (in-list wraps)]) - (match wrap - [(struct phase-shift (amt src dest cancel-id)) - (box (vector amt src dest #f #f cancel-id))] - [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) - (define encoded-kind (eq? kind 'marked)) - (define encoded-unmarshals (map encode-all-from-module unmarshals)) - (define encoded-renames (encode-module-bindings renames)) - (define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals) - (values encoded-renames mark-renames) - (values encoded-unmarshals (cons encoded-renames mark-renames)))) - (define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames)) - (if plus-kern? - (cons #t mod-rename) - mod-rename)] - [(struct lexical-rename (bool1 bool2 alist)) - (define len (length alist)) - (define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning - (vector-set! vec 0 bool1) - (vector-set! vec 1 bool2) - (for ([(k v) (in-dict alist)] - [i (in-naturals)]) - (vector-set! vec (+ 2 i) k) - (vector-set! vec (+ 2 i len) v)) - vec] - [(struct top-level-rename (flag)) - flag] - [(struct mark-barrier (value)) - value] - [(struct prune (syms)) - (box syms)] - [(struct wrap-mark (val)) - (list val)]))) + #f) (define (encode-mark-map mm) mm @@ -678,11 +648,6 @@ out)] [(struct global-bucket (name)) (out-marshaled variable-type-num name out)] - [(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?)) - (out-marshaled - free-id-info-type-num - (vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?) - out)] [(? mod?) (out-module v out)] [(struct def-values (ids rhs)) @@ -1112,13 +1077,14 @@ (define (pack-binding-names binding-names) (define (ht-to-vector ht) - (list->vector (apply append (hash-map ht list)))) + (and ht (list->vector (apply append (hash-map ht list))))) (list (ht-to-vector (hash-ref binding-names 0 #f)) (ht-to-vector (hash-ref binding-names 1 #f)) - (apply append - (for/list ([(phase ht) (in-hash binding-names)] - #:unless (or (= phase 0) (= phase 1))) - (list phase (ht-to-vector ht)))))) + (list->vector + (apply append + (for/list ([(phase ht) (in-hash binding-names)] + #:unless (or (= phase 0) (= phase 1))) + (list phase (ht-to-vector ht))))))) (define (out-lam expr out) (match expr diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 10a84811ce..80b82e3256 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -72,11 +72,6 @@ ;; XXX Why not leave them as vectors and change the contract? (make-prefix i (vector->list tv) (vector->list sv))])) -(define read-free-id-info - (match-lambda - [(vector mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0) ; I have no idea what these mean - (make-free-id-info mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0)])) - (define (read-unclosed-procedure v) (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) @@ -422,7 +417,6 @@ (cons 'module-type read-module) (cons 'inline-variant-type read-inline-variant) (cons 'resolve-prefix-type read-resolve-prefix) - (cons 'free-id-info-type read-free-id-info) (cons 'define-values-type read-define-values) (cons 'define-syntaxes-type read-define-syntax) (cons 'begin-for-syntax-type read-begin-for-syntax) @@ -513,8 +507,9 @@ [34 prefab] [35 let-one-unused] [36 mark] - [37 shared] - [38 62 small-number] + [37 root-mark] + [38 shared] + [39 62 small-number] [62 80 small-symbol] [80 92 small-marshalled] [92 ,(+ 92 small-list-max) small-proper-list] diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index bd97241008..230e047c97 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -195,34 +195,6 @@ ;; Top-level `require' (define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) - -(define-form-struct free-id-info ([path0 module-path-index?] - [symbol0 symbol?] - [path1 module-path-index?] - [symbol1 symbol?] - [phase0 (or/c exact-integer? #f)] - [phase1 (or/c exact-integer? #f)] - [phase2 (or/c exact-integer? #f)] - [use-current-inspector? boolean?])) - -(define-form-struct (lexical-rename wrap) ([has-free-id-renames? boolean?] - [bool2 boolean?] ; this needs a name - [alist (listof - (cons/c symbol? - (or/c - symbol? - (cons/c - symbol? - (or/c - (cons/c symbol? (or/c symbol? #f)) - free-id-info?)))))])) -(define-form-struct (phase-shift wrap) ([amt (or/c exact-integer? #f)] - [src (or/c module-path-index? #f)] - [dest (or/c module-path-index? #f)] - [cancel-id (or/c exact-integer? #f)])) -(define-form-struct (wrap-mark wrap) ([val exact-integer?])) -(define-form-struct (prune wrap) ([sym any/c])) - (define-form-struct all-from-module ([path module-path-index?] [phase (or/c exact-integer? #f)] [src-phase (or/c exact-integer? #f)] From bbfdc73e5d691ef9880280330455a779b008a212 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 11 Mar 2015 18:36:26 -0600 Subject: [PATCH 418/466] update for inspector descriptor in prefix bytecode --- compiler-lib/compiler/decompile.rkt | 19 +++++++++++-------- compiler-lib/compiler/demodularizer/merge.rkt | 10 ++++++---- compiler-lib/compiler/demodularizer/nodep.rkt | 6 ++++-- zo-lib/compiler/zo-marshal.rkt | 12 +++++++----- zo-lib/compiler/zo-parse.rkt | 4 ++-- zo-lib/compiler/zo-structs.rkt | 3 ++- 6 files changed, 32 insertions(+), 22 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index b32d002882..524ce7a7b1 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -126,7 +126,7 @@ (define (decompile-prefix a-prefix stx-ht) (match a-prefix - [(struct prefix (num-lifts toplevels stxs)) + [(struct prefix (num-lifts toplevels stxs src-insp-desc)) (let ([lift-ids (for/list ([i (in-range num-lifts)]) (gensym 'lift))] [stx-ids (map (lambda (i) (gensym 'stx)) @@ -169,12 +169,14 @@ (length toplevels) (length stxs) num-lifts) - (map (lambda (stx id) - `(define ,id ,(if stx - `(#%decode-syntax - ,(decompile-stx (stx-encoded stx) stx-ht)) - #f))) - stxs stx-ids)))] + (cons + `(quote inspector ,src-insp-desc) + (map (lambda (stx id) + `(define ,id ,(if stx + `(#%decode-syntax + ,(decompile-stx (stx-encoded stx) stx-ht)) + #f))) + stxs stx-ids))))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) (define (decompile-stx stx stx-ht) @@ -216,7 +218,8 @@ (define (decompile-module mod-form orig-stack stx-ht mod-name) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported + [(struct mod (name srcname self-modidx + prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context binding-names flags pre-submodules post-submodules)) diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt index 2bbaa5344b..71202724f2 100644 --- a/compiler-lib/compiler/demodularizer/merge.rkt +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -54,12 +54,13 @@ (define (merge-prefix root-prefix mod-prefix) (match root-prefix - [(struct prefix (root-num-lifts root-toplevels root-stxs)) + [(struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) (match mod-prefix - [(struct prefix (mod-num-lifts mod-toplevels mod-stxs)) + [(struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) (make-prefix (+ root-num-lifts mod-num-lifts) (append root-toplevels mod-toplevels) - (append root-stxs mod-stxs))])])) + (append root-stxs mod-stxs) + root-src-insp-desc)])])) (struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) @@ -121,7 +122,8 @@ (define (merge-module max-let-depth top-prefix mod-form) (match mod-form - [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies + [(struct mod (name srcname self-modidx + mod-prefix provides requires body syntax-bodies unexported mod-max-let-depth dummy lang-info internal-context binding-names flags pre-submodules post-submodules)) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index 5db811eb4b..59995fc9e0 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -139,7 +139,8 @@ (define (nodep-module mod-form phase) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies + [(struct mod (name srcname self-modidx + prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context binding-names flags pre-submodules post-submodules)) @@ -158,7 +159,8 @@ (append (requires->modlist requires phase) (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx new-prefix provides requires body empty + (list (make-mod name srcname self-modidx + new-prefix provides requires body empty unexported max-let-depth dummy lang-info internal-context #hash() empty empty empty))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index a05642fa37..de99445d5d 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -639,12 +639,13 @@ (let ([pos ((out-shared-index out) v #:error? #t)]) (out-number pos out) (out-anything lam out))] - [(struct prefix (num-lifts toplevels stxs)) + [(struct prefix (num-lifts toplevels stxs src-insp-desc)) (out-marshaled prefix-type-num - (cons num-lifts - (cons (list->vector toplevels) - (list->vector stxs))) + (list* src-insp-desc + num-lifts + (list->vector toplevels) + (list->vector stxs)) out)] [(struct global-bucket (name)) (out-marshaled variable-type-num name out)] @@ -963,7 +964,8 @@ (define (convert-module mod-form) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported + [(struct mod (name srcname self-modidx + prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context binding-names flags pre-submodules post-submodules)) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 80b82e3256..1788f7153b 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -68,9 +68,9 @@ (define (read-resolve-prefix v) (match v - [`(,i ,tv . ,sv) + [`(,src-insp-desc ,i ,tv . ,sv) ;; XXX Why not leave them as vectors and change the contract? - (make-prefix i (vector->list tv) (vector->list sv))])) + (make-prefix i (vector->list tv) (vector->list sv) src-insp-desc)])) (define (read-unclosed-procedure v) (define CLOS_HAS_REST 1) diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index 230e047c97..7ae356ec28 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -81,7 +81,8 @@ (define-form-struct prefix ([num-lifts exact-nonnegative-integer?] [toplevels (listof (or/c #f symbol? global-bucket? module-variable?))] - [stxs list?])) ; should be (listof stx?) sets up top-level and syntax-object array + [stxs list?] ; should be (listof stx?) sets up top-level and syntax-object array + [src-inspector-desc symbol?])) (define-form-struct form ()) (define-form-struct (expr form) ()) From 6a2e75c4545829e3b24fdd23657b296909e015e4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Mar 2015 17:26:51 -0600 Subject: [PATCH 419/466] adjust bindings-table encoding --- compiler-lib/compiler/decompile.rkt | 6 ++++-- zo-lib/compiler/zo-structs.rkt | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 524ce7a7b1..d048b3b90b 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -237,8 +237,10 @@ (values phase (for/hash ([(sym id) (in-hash ht)]) (values sym - `(#%decode-syntax - ,(decompile-stx (stx-encoded id) stx-ht))))))) + (if (eq? id #t) + #t + `(#%decode-syntax + ,(decompile-stx (stx-encoded id) stx-ht)))))))) (quote language-info ,lang-info) ,@(if (null? flags) '() (list `(quote ,flags))) ,@(let ([l (apply diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index 7ae356ec28..d6f9e19ff5 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -140,7 +140,7 @@ [lang-info (or/c #f (vector/c module-path? symbol? any/c))] [internal-context (or/c #f #t stx? (vectorof stx?))] [binding-names (hash/c exact-integer? - (hash/c symbol? stx?))] + (hash/c symbol? (or/c #t stx?)))] [flags (listof (or/c 'cross-phase))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) From 56a8886525ea70cb0ca70be4157bfa726f5ce132 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Mar 2015 06:59:17 -0600 Subject: [PATCH 420/466] update to 6.2.0.18 bytecode format --- zo-lib/compiler/zo-marshal.rkt | 2 +- zo-lib/compiler/zo-parse.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index de99445d5d..13ed9bc42e 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -288,7 +288,7 @@ (define module-type-num 26) (define inline-variants-type-num 27) (define variable-type-num 35) -(define prefix-type-num 115) +(define prefix-type-num 120) (define-syntax define-enum (syntax-rules () diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 1788f7153b..aec5c78cd1 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -395,7 +395,7 @@ [(27) 'inline-variant-type] [(35) 'variable-type] [(36) 'module-variable-type] - [(115) 'resolve-prefix-type] + [(120) 'resolve-prefix-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers From 3d4607099441ab27d63c1725518c45edcac62036 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 Apr 2015 18:57:52 -0600 Subject: [PATCH 421/466] add structures, decoding, and encoding for zo syntax objects --- compiler-lib/compiler/decompile.rkt | 20 +- .../compiler/demodularizer/module.rkt | 2 +- compiler-lib/compiler/demodularizer/nodep.rkt | 4 +- compiler-test/tests/compiler/zo-exs.rkt | 14 +- zo-lib/compiler/zo-marshal.rkt | 348 ++++++++++++--- zo-lib/compiler/zo-parse.rkt | 414 +++++++++++++----- zo-lib/compiler/zo-structs.rkt | 126 +++--- 7 files changed, 665 insertions(+), 263 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index d048b3b90b..cde92e1104 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -116,6 +116,16 @@ (for/list ([(k v) (in-hash e)]) (cons (loop k) (loop v))))) ph] + [(prefab-struct-key e) + => (lambda (k) + (define ph (make-placeholder #f)) + (hash-set! ht e ph) + (placeholder-set! ph + (apply make-prefab-struct + k + (map loop + (cdr (vector->list (struct->vector e)))))) + ph)] [else e]))) (define l (make-reader-graph (cons main mconses))) @@ -174,7 +184,7 @@ (map (lambda (stx id) `(define ,id ,(if stx `(#%decode-syntax - ,(decompile-stx (stx-encoded stx) stx-ht)) + ,(decompile-stx (stx-content stx) stx-ht)) #f))) stxs stx-ids))))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -184,7 +194,7 @@ (let ([p (mcons #f #f)]) (hash-set! stx-ht stx p) (match stx - [(wrapped datum wraps tamper-status) + [(stx-obj datum wrap tamper-status) (set-mcar! p (case tamper-status [(clean) 'wrap] [(tainted) 'wrap-tainted] @@ -207,7 +217,7 @@ [(box? datum) (box (decompile-stx (unbox datum) stx-ht))] [else datum]) - wraps)) + wrap)) p])))) (define (mpi->string modidx) @@ -231,7 +241,7 @@ (quote internal-context ,(if (stx? internal-context) `(#%decode-syntax - ,(decompile-stx (stx-encoded internal-context) stx-ht)) + ,(decompile-stx (stx-content internal-context) stx-ht)) internal-context)) (quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)]) (values phase @@ -240,7 +250,7 @@ (if (eq? id #t) #t `(#%decode-syntax - ,(decompile-stx (stx-encoded id) stx-ht)))))))) + ,(decompile-stx (stx-content id) stx-ht)))))))) (quote language-info ,lang-info) ,@(if (null? flags) '() (list `(quote ,flags))) ,@(let ([l (apply diff --git a/compiler-lib/compiler/demodularizer/module.rkt b/compiler-lib/compiler/demodularizer/module.rkt index 1be8d31309..f33b675008 100644 --- a/compiler-lib/compiler/demodularizer/module.rkt +++ b/compiler-lib/compiler/demodularizer/module.rkt @@ -17,7 +17,7 @@ (define-values (reqs new-forms) (partition req? (splice-forms form))) (define requires - (map (compose ->module-path-index wrapped-datum stx-encoded req-reqs) reqs)) + (map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs)) (make-compilation-top 0 (make-prefix 0 (list #f) empty) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index 59995fc9e0..d1652826ff 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -197,13 +197,13 @@ empty (begin (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-wrapped ct empty 'clean)) (make-toplevel 0 0 #f #f)))))] + (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))] [(module-path-index? ct) (if (hash-has-key? REQUIRED ct) empty (begin (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-wrapped ct empty 'clean)) (make-toplevel 0 0 #f #f)))))] + (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))] [(not ct) empty] [(@phase? ct) diff --git a/compiler-test/tests/compiler/zo-exs.rkt b/compiler-test/tests/compiler/zo-exs.rkt index fbf325980f..03c836bbd0 100644 --- a/compiler-test/tests/compiler/zo-exs.rkt +++ b/compiler-test/tests/compiler/zo-exs.rkt @@ -28,16 +28,16 @@ (test (roundtrip (compilation-top 0 - (prefix 0 empty empty) + (prefix 0 empty empty 'insp0) (list 1 (list 2 3) (list 2 3) 4 5))) (roundtrip (compilation-top 0 - (prefix 1 empty empty) + (prefix 1 empty empty 'insp0) (list (lam 'proc null 0 null #f #(0) '(val/ref) (set 0) 3 1)))) (roundtrip (compilation-top 0 - (prefix 1 empty empty) + (prefix 1 empty empty 'insp0) (list (lam 'proc null 0 null #f #(0) '(val/ref) #f 3 1)))) #;(roundtrip @@ -94,23 +94,23 @@ (roundtrip (compilation-top 0 - (prefix 0 empty empty) + (prefix 0 empty empty 'insp0) (current-directory))) (roundtrip (compilation-top 0 - (prefix 0 empty empty) + (prefix 0 empty empty 'insp0) (list (current-directory)))) (roundtrip (compilation-top 0 - (prefix 0 empty empty) + (prefix 0 empty empty 'insp0) (cons #hash() #hash()))) (roundtrip (compilation-top 0 - (prefix 0 empty empty) + (prefix 0 empty empty 'insp0) #hash()))) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 13ed9bc42e..6c4e657a3d 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -20,6 +20,8 @@ (struct not-ready ()) +(struct encoded-scope ([content #:mutable]) #:prefab) + (define (zo-marshal top) (define bs (open-output-bytes)) (zo-marshal-to top bs) @@ -142,8 +144,10 @@ (define (zo-marshal-top-to top outp) - ; XXX: wraps were encoded in traverse, now needs to be handled when writing - (define wrapped (make-hash)) + ; For detecting sharing in wraps: + (define stx-objs (make-hasheq)) + (define wraps (make-hasheq)) + (define hash-consed (make-hash)) ; (obj -> (or pos #f)) output-port -> number ; writes top to outp using shared-obj-pos to determine symref @@ -153,7 +157,8 @@ (match top [(compilation-top max-let-depth prefix form) (list* max-let-depth prefix (protect-quote form))])) - (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee wrapped)) + (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee + stx-objs wraps hash-consed)) (file-position outp)) ; -> vector @@ -227,7 +232,8 @@ [i (in-naturals)]) (begin0 (file-position outp) - (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void wrapped)))) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void + stx-objs wraps hash-consed)))) (file-position outp))) ; Calculate file positions @@ -336,8 +342,8 @@ CPT_DELAY_REF ; XXX unused, but appears to be same as CPT_SYMREF CPT_PREFAB CPT_LET_ONE_UNUSED - CPT_MARK - CPT_ROOT_MARK + CPT_SCOPE + CPT_ROOT_SCOPE CPT_SHARED) (define CPT_SMALL_NUMBER_START 39) @@ -383,68 +389,23 @@ #f #f)) -(define (encode-module-bindings module-bindings) - (define encode-nominal-path - (match-lambda - [(struct simple-nominal-path (value)) - value] - [(struct imported-nominal-path (value import-phase)) - (cons value import-phase)] - [(struct phased-nominal-path (value import-phase phase)) - (cons value (cons import-phase phase))])) - (define encoded-bindings (make-vector (* (length module-bindings) 2))) - (for ([i (in-naturals)] - [(k v) (in-dict module-bindings)]) - (vector-set! encoded-bindings (* i 2) k) - (vector-set! encoded-bindings (add1 (* i 2)) - (match v - [(struct simple-module-binding (path)) - path] - [(struct exported-module-binding (path export-name)) - (cons path export-name)] - [(struct nominal-module-binding (path nominal-path)) - (cons path (encode-nominal-path nominal-path))] - [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) - (list* path export-name (encode-nominal-path nominal-path) nominal-export-name)] - [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) - (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) - encoded-bindings) - -(define (encode-all-from-module afm) - (match afm - [(struct all-from-module (path phase src-phase '() #f '())) - (list* path phase src-phase)] - [(struct all-from-module (path phase src-phase '() #f context)) - (list* path phase context src-phase)] - [(struct all-from-module (path phase src-phase exns prefix '())) - (list* path phase src-phase exns prefix)])) - -(define (encode-wraps wraps) - #f) - -(define (encode-mark-map mm) - mm - #;(for/fold ([l empty]) - ([(k v) (in-hash ht)]) - (list* k v l))) - (define-struct protected-symref (val)) -(define (encode-wrapped w) +(define (encode-stx-obj w wraps-ht) (match w - [(struct wrapped (datum wraps tamper-status)) + [(struct stx-obj (datum wraps tamper-status)) (let* ([enc-datum (match datum [(cons a b) - (let ([p (cons (encode-wrapped a) + (let ([p (cons (encode-stx-obj a wraps-ht) (let bloop ([b b]) (match b ['() null] [(cons b1 b2) - (cons (encode-wrapped b1) + (cons (encode-stx-obj b1 wraps-ht) (bloop b2))] [else - (encode-wrapped b)])))] + (encode-stx-obj b wraps-ht)])))] ; XXX Cylic list error possible [len (let loop ([datum datum][len 0]) (cond @@ -457,24 +418,24 @@ (cons len p) p))] [(box x) - (box (encode-wrapped x))] + (box (encode-stx-obj x wraps-ht))] [(? vector? v) - (vector-map encode-wrapped v)] + (vector-map (lambda (e) (encode-stx-obj e wraps-ht)) v)] [(? prefab-struct-key) (define l (vector->list (struct->vector datum))) (apply make-prefab-struct (car l) - (map encode-wrapped (cdr l)))] + (map (lambda (e) (encode-stx-obj e wraps-ht)) (cdr l)))] [_ datum])] [p (cons enc-datum - (encode-wraps wraps))]) + (encode-wrap wraps wraps-ht))]) (case tamper-status [(clean) p] [(tainted) (vector p)] [(armed) (vector p #f)]))])) -(define-struct out (s shared-index shared-unsee encoded-wraps)) +(define-struct out (s shared-index shared-unsee stx-objs wraps hash-consed)) (define (out-shared v out k) (if (shareable? v) (let ([v ((out-shared-index out) v)]) @@ -523,7 +484,9 @@ (define (shareable? v) (define never-share-this? - (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?)) + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? + ;; For root scope: + scope?)) (define always-share-this? (or-pred? v closure?)) (or always-share-this? @@ -584,6 +547,8 @@ (out-byte CPT_FALSE out)] [(? void?) (out-byte CPT_VOID out)] + [(? (lambda (s) (and (scope? s) (eq? (scope-name s) 'root)))) + (out-byte CPT_ROOT_SCOPE out)] [(struct module-variable (modidx sym pos phase constantness)) (define (to-sym n) (string->symbol (format "struct~a" n))) (out-byte CPT_MODULE_VAR out) @@ -917,11 +882,23 @@ (out-anything base out) (unless (or name base) (out-anything (module-path-index-submodule v) out)))] - [(stx encoded) + [(stx content) (out-byte CPT_STX out) - (out-anything encoded out)] - [(? wrapped?) - (out-anything (lookup-encoded-wrapped v out) out)] + ;; The core Racket printer currently records more sharing + ;; by ensureing that list tails are shared, while the printer + ;; here detects sharing only at the start of a list. That + ;; doesn't seem to matter much. Meanwhile, we ensure that + ;; as much sharing as possible is present before printing. + (out-anything content out)] + [(encoded-scope content) + (out-byte CPT_SCOPE out) + ;; The `out-shared` wrapper already called `((out-shared-index out) v)` + ;; once, so `pos` will defintely be a number: + (let ([pos ((out-shared-index out) v)]) + (out-number pos out)) + (out-anything (share-everywhere content out) out)] + [(? stx-obj?) + (out-anything (lookup-encoded-stx-obj v out) out)] [(? prefab-struct-key) (define pre-v (struct->vector v)) (vector-set! pre-v 0 (prefab-struct-key v)) @@ -1072,10 +1049,10 @@ [l (cons (if (pair? name) (cdr name) null) l)]) l)])) -(define (lookup-encoded-wrapped w out) - (hash-ref! (out-encoded-wraps out) w - (λ () - (encode-wrapped w)))) +(define (lookup-encoded-stx-obj w out) + (hash-ref! (out-stx-objs out) w + (λ () + (encode-stx-obj w (out-wraps out))))) (define (pack-binding-names binding-names) (define (ht-to-vector ht) @@ -1178,6 +1155,237 @@ (find-relative-path r v) v))) +;; ---------------------------------------- + +;; We want to hash-cons syntax-object wraps, but a normal `equal?`-based +;; table would equate different "self" modidxes that we need to keep +;; separate. So, roll a `simple-equal?` that inspects wraps. We don't +;; have to deal with cycles, since cycles would always go through a scope, +;; and we recur into scopes. + +(struct modidx-must-be-eq (content) + #:property prop:equal+hash + (list (lambda (a b eql?) + (simple-equal? (modidx-must-be-eq-content a) + (modidx-must-be-eq-content b))) + (lambda (a h) (h (modidx-must-be-eq-content a))) + (lambda (a h) (h (modidx-must-be-eq-content a))))) + +(define (simple-equal? a b) + (cond + [(eqv? a b) #t] + [(pair? a) + (and (pair? b) + (simple-equal? (car a) (car b)) + (simple-equal? (cdr a) (cdr b)))] + [(vector? a) + (and (vector? b) + (= (vector-length a) (vector-length b)) + (for/and ([ae (in-vector a)] + [be (in-vector b)]) + (simple-equal? ae be)))] + [(box? a) + (and (box? b) + (simple-equal? (unbox a) (unbox b)))] + [else #f])) + +(define (share-everywhere v out) + (hash-ref! (out-hash-consed out) + (modidx-must-be-eq v) + (lambda () + (cond + [(pair? v) + (cons (share-everywhere (car v) out) + (share-everywhere (cdr v) out))] + [(vector? v) + (for/vector #:length (vector-length v) ([e (in-vector v)]) + (share-everywhere e out))] + [(box? v) + (box (share-everywhere (unbox v) out))] + [else v])))) ;; ---------------------------------------- +(define (encode-wrap w ht) + (hash-ref! ht w + (lambda () + (vector (map-encode encode-shift (wrap-shifts w) ht) + (encode-scope-list (wrap-simple-scopes w) ht) + (map-encode encode-multi-scope (wrap-multi-scopes w) ht))))) + +(define (map-encode encode l ht) + (cond + [(null? l) l] + [else + (hash-ref! ht l + (lambda () + (cons (encode (car l) ht) + (map-encode encode (cdr l) ht))))])) + +(define (encode-shift s ht) + (hash-ref! ht s + (lambda () + (if (module-shift-from-inspector-desc s) + (vector (module-shift-to s) + (module-shift-from s) + (module-shift-from-inspector-desc s) + (module-shift-to-inspector-desc s)) + (vector (module-shift-to s) + (module-shift-from s)))))) + +(define (encode-scope s ht) + (if (eq? 'root (scope-name s)) + s + (hash-ref ht s + (lambda () + (define es (encoded-scope #f)) + (hash-set! ht s es) + (define kind + (case (scope-kind s) + [(module) (if (scope-multi-owner s) + 1 + 0)] + [(macro) 2] + [(local) 3] + [(intdef) 4] + [else 5])) + (cond + [(and (null? (scope-bindings s)) + (null? (scope-bulk-bindings s))) + (set-encoded-scope-content! es kind)] + [else + (define binding-table + (for/fold ([bt (hasheq)]) ([b (in-list (scope-bindings s))]) + (hash-set bt + (car b) + (cons (cons (encode-scope-list (cadr b) ht) + (encode-binding (caddr b) (car b) ht)) + (hash-ref bt (car b) null))))) + (define bindings + (list->vector + (apply + append + (sort (hash-map binding-table list) + symbol #:key (lambda (s) + (if (eq? 'root (scope-name s)) + -1 + (scope-name s)))) + ht)) + +(define (encode-multi-scope ms+phase ht) + (define ms (car ms+phase)) + (cons (hash-ref ht ms + (lambda () + (define v (make-vector (add1 (* 2 (length (multi-scope-scopes ms)))))) + (hash-set! ht ms v) + (vector-copy! + v + 0 + (list->vector + (append (apply + append + (for/list ([e (in-list (multi-scope-scopes ms))]) + (list (car e) + (encode-scope (cadr e) ht)))) + (list (multi-scope-src-name ms))))) + v)) + (cadr ms+phase))) + +(define (encode-binding b name ht) + (match b + [(free-id=?-binding base id) + (hash-ref ht b + (lambda () + (match b + [(free-id=?-binding base id) + (define bx (box #f)) + (hash-set! ht b bx) + (set-box! bx + (cons (encode-binding base name ht) + (cons (stx-obj-datum id) + (stx-obj-wrap id))))])))] + [_ + (hash-ref! ht b + (lambda () + (match b + [(local-binding name) + name] + [(module-binding encoded) + encoded] + [(? decoded-module-binding?) + (encode-module-binding b name ht)])))])) + + +(define (encode-module-binding b name ht) + (hash-ref! ht (cons name b) + (lambda () + (match b + [(decoded-module-binding path export-name phase + nominal-path nominal-export-name nominal-phase + import-phase inspector-desc) + (define l + (cond + [(and (eq? path nominal-path) + (eq? export-name nominal-export-name) + (eqv? phase 0) + (eqv? import-phase 0) + (eqv? nominal-phase phase)) + (if (eq? name export-name) + path + (cons path export-name))] + [(and (eq? export-name nominal-export-name) + (eq? name export-name) + (eqv? 0 phase) + (eqv? import-phase 0) + (eqv? nominal-phase phase)) + (cons path nominal-path)] + [else + (define nom-mod+phase + (if (eqv? nominal-phase phase) + (if (eqv? 0 import-phase) + nominal-path + (cons nominal-path import-phase)) + (cons nominal-path (cons import-phase nominal-phase)))) + (define l (list* export-name nom-mod+phase nominal-export-name)) + (if (zero? phase) + l + (cons phase l))])) + (if inspector-desc + (cons inspector-desc l) + l)])))) + +(define (encode-bulk-binding p ht) + (cons (encode-scope-list (car p) ht) + (encode-all-from-module (cadr p) ht))) + +(define (encode-all-from-module b ht) + (hash-ref! ht b + (lambda () + (match b + [(all-from-module path phase src-phase inspector-desc exceptions prefix) + (vector path src-phase + (cond + [(and (not prefix) (null? exceptions)) + phase] + [(not prefix) + (cons phase (list->vector exceptions))] + [(null? exceptions) + (cons phase prefix)] + [else + (cons phase (cons (list->vector exceptions) prefix))]) + inspector-desc)])))) + diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index aec5c78cd1..dc53a5bc75 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -7,28 +7,10 @@ racket/dict racket/set) -(provide zo-parse) +(provide zo-parse + decode-module-binding) (provide (all-from-out compiler/zo-structs)) -#| Unresolved Issues - - The order of indirect-et-provides, indirect-syntax-provides, indirect-provides was changed, is that okay? - - orig-port of cport struct is never used, is it needed? - - Lines 628, 630 seem to be only for debugging and should probably throw errors - - vector and pair cases of decode-wraps seem to do different things from the corresponding C code - - Line 816: This should be an eqv placeholder (but they don't exist) - - Line 634: Export registry is always matched as false, but might not be - - What are the real differences between the module-binding cases? - - I think parse-module-path-index was only used for debugging, so it is short-circuited now - -|# ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -506,8 +488,8 @@ [33 delayed] [34 prefab] [35 let-one-unused] - [36 mark] - [37 root-mark] + [36 scope] + [37 root-scope] [38 shared] [39 62 small-number] [62 80 small-symbol] @@ -521,6 +503,8 @@ [249 small-application3] [247 255 small-application])) +(define root-scope (scope 'root 'module null null #f)) + ;; To accelerate cpt-table lookup, we flatten out the above ;; list into a vector: (define cpt-table (make-vector 256 #f)) @@ -607,7 +591,10 @@ (define-syntax-rule (with-memo mt arg body ...) (with-memo* mt arg (λ () body ...))) -(define (decode-stx cp v) +;; placeholder for a `scope` decoded in a second pass: +(struct encoded-scope (content) #:prefab) + +(define (decode-wrapped cp v) (let loop ([v v]) (let-values ([(tamper-status v encoded-wraps) (match v @@ -615,9 +602,8 @@ [`#((,datum . ,wraps) #f) (values 'armed datum wraps)] [`(,datum . ,wraps) (values 'clean datum wraps)] [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) - (let* ([wraps (decode-wraps cp encoded-wraps)] - [wrapped-memo (make-memo)] - [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps tamper-status)))]) + (let* ([wrapped-memo (make-memo)] + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps tamper-status)))]) (cond [(pair? v) (if (eq? #t (car v)) @@ -670,35 +656,6 @@ (map loop (struct->list v)))))] [else (add-wrap v)]))))) -(define (afm-context? v) - (or (and (list? v) (andmap exact-integer? v)) - (and (vector? v) - (= 2 (vector-length v)) - (list? (vector-ref v 0)) - (andmap exact-integer? (vector-ref v 0))))) - -(define all-from-module-memo (make-memo)) -(define (decode-all-from-module cp afm) - (define (phase? v) - (or (number? v) (not v))) - (with-memo all-from-module-memo afm - (match afm - [(list* path (? phase? phase) (? phase? src-phase) (list exn ...) prefix) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase exn prefix null)] - [(list* path (? phase? phase) (? afm-context? context) (? phase? src-phase)) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase null #f context)] - [(list* path (? phase? phase) (? phase? src-phase)) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase null #f null)]))) - -(define (decode-wraps cp w) - w) - (define (in-vector* v n) (make-do-sequence (λ () @@ -709,49 +666,6 @@ (λ _ #t) (λ _ #t))))) -(define nominal-path-memo (make-memo)) -(define (decode-nominal-path np) - (with-memo nominal-path-memo np - (match np - [(cons nominal-path (cons import-phase nominal-phase)) - (make-phased-nominal-path nominal-path import-phase nominal-phase)] - [(cons nominal-path import-phase) - (make-imported-nominal-path nominal-path import-phase)] - [nominal-path - (make-simple-nominal-path nominal-path)]))) - -; XXX Weird test copied from C code. Matthew? -(define (nom_mod_p p) - (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) - -(define rename-v-memo (make-memo)) -(define (decode-rename-v v) - (with-memo rename-v-memo v - (match v - [(list-rest path phase export-name nominal-path nominal-export-name) - (make-phased-module-binding path - phase - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(list-rest path export-name nominal-path nominal-export-name) - (make-exported-nominal-module-binding path - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(cons module-path-index (? nom_mod_p nominal-path)) - (make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))] - [(cons module-path-index export-name) - (make-exported-module-binding module-path-index export-name)] - [module-path-index - (make-simple-module-binding module-path-index)]))) - -(define renames-memo (make-memo)) -(define (decode-renames renames) - (with-memo renames-memo renames - (for/list ([(k v) (in-vector* renames 2)]) - (cons k (decode-rename-v v))))) - (define (parse-module-path-index cp s) s) @@ -934,7 +848,7 @@ [(marshalled) (read-marshalled (read-compact-number cp) cp)] [(stx) (let ([v (read-compact cp)]) - (make-stx (decode-stx cp v)))] + (make-stx (decode-wrapped cp v)))] [(local local-unbox) (let ([c (read-compact-number cp)] [unbox? (eq? cpt-tag 'local-unbox)]) @@ -1027,11 +941,13 @@ (read-compact-svector cp (read-compact-number cp))] [(small-svector) (read-compact-svector cp (- ch cpt-start))] - [(mark) + [(scope) (let ([pos (read-compact-number cp)]) (if (zero? pos) - (box (read-compact cp)) - (read-cyclic cp pos 'mark box)))] + (encoded-scope (read-compact cp)) + (read-cyclic cp pos 'scope encoded-scope)))] + [(root-scope) + root-scope] [(shared) (let ([pos (read-compact-number cp)]) (read-cyclic cp pos 'shared))] @@ -1210,7 +1126,299 @@ #;(for ([(i v) (in-dict (cport-symtab cp))]) (printf "~a = ~a\n" i (placeholder-get v))) (set-cport-pos! cp shared-size) - (make-reader-graph (read-marshalled 'compilation-top-type cp))) + + (define decoded-except-for-stx + (make-reader-graph (read-marshalled 'compilation-top-type cp))) + + (decode-stxes decoded-except-for-stx)) + +;; ---------------------------------------- + +(define (decode-stxes v) + ;; Walk `v` to find `stx-obj` instances and decode the `wrap` field. + ;; We do this after building a graph from the input, and `decode-wrap` + ;; preserves graph structure. + (define decode-ht (make-hasheq)) + (let walk ([p v]) + (match p + [(compilation-top _ pfx c) + (struct-copy compilation-top p + [prefix (walk pfx)] + [code (walk c)])] + [(prefix _ _ s _) + (struct-copy prefix p [stxs (map walk s)])] + [(req rs _) + (struct-copy req p + [reqs (map walk rs)])] + [(? mod?) + (struct-copy mod p + [prefix (walk (mod-prefix p))] + [syntax-bodies + (for/list ([e (in-list (mod-syntax-bodies p))]) + (cons (car e) + (map walk (cdr e))))] + [internal-context + (walk (mod-internal-context p))] + [binding-names + (for/hash ([(p ht) (in-hash (mod-binding-names p))]) + (values p + (for/hash ([(k v) (in-hash ht)]) + (values k (walk v)))))] + [pre-submodules + (map walk (mod-pre-submodules p))] + [post-submodules + (map walk (mod-post-submodules p))])] + [(stx c) + (struct-copy stx p [content (walk c)])] + [(def-syntaxes _ _ pfx _ _) + (struct-copy def-syntaxes p + [prefix (walk pfx)])] + [(seq-for-syntax _ pfx _ _) + (struct-copy seq-for-syntax p + [prefix (walk pfx)])] + [(stx-obj d w _) + (struct-copy stx-obj p + [datum (walk d)] + [wrap (decode-wrap w decode-ht)])] + [(? zo?) p] + ;; Generic constructors happen inside the `datum` of `stx-obj`, + ;; for example (with no cycles): + [(cons a d) + (cons (walk a) (walk d))] + [(? vector?) + (vector->immutable-vector + (for/vector #:length (vector-length p) ([e (in-vector p)]) + (walk e)))] + [(box v) + (box-immutable (walk v))] + [(? prefab-struct-key) + (apply make-prefab-struct + (prefab-struct-key p) + (cdr (for/list ([e (in-vector (struct->vector p))]) + (walk e))))] + [(? hash?) + (cond + [(hash-eq? p) + (for/hasheq ([(k v) (in-hash p)]) + (values k (walk v)))] + [(hash-eqv? p) + (for/hasheqv ([(k v) (in-hash p)]) + (values k (walk v)))] + [else + (for/hash ([(k v) (in-hash p)]) + (values k (walk v)))])] + [_ p]))) + +;; ---------------------------------------- + +(define (decode-wrap encoded-wrap ht) + (hash-ref! ht + encoded-wrap + (lambda () + (match encoded-wrap + [(vector shifts simple-scopes multi-scopes) + (make-wrap (decode-map decode-shift shifts ht) + (decode-map decode-scope simple-scopes ht) + (decode-map decode-shifted-multi-scope multi-scopes ht))] + [_ (error 'decode-wrap "bad wrap")])))) + +(define (decode-map decode-one l ht) + (cond + [(null? l) l] + [(not (pair? l)) + (error 'decode-wrap "bad list")] + [else (hash-ref! ht l + (lambda () + (cons (decode-one (car l) ht) + (decode-map decode-one (cdr l) ht))))])) + +(define (decode-shift s ht) + (hash-ref! ht s + (lambda () + (match s + [(vector to from) + (module-shift to from #f #f)] + [(vector to from i-to i-from) + (module-shift to from i-to i-from)] + [_ (error 'decode-wrap "bad shift")])))) + +(define (decode-scope s ht) + (hash-ref ht s + (lambda () + (unless (encoded-scope? s) + (error 'decode-wrap "bad scope: ~e" s)) + (define v (encoded-scope-content s)) + (define kind + (match v + [(? number?) v] + [(cons (? number?) _) + (car v)] + [else (error 'decode-wrap "bad scope")])) + (define sc (scope (hash-count ht) + (case kind + [(0 1) 'module] + [(2) 'macro] + [(3) 'local] + [(4) 'intdef] + [else 'use-site]) + null + null + #f)) + (hash-set! ht s sc) + (unless (number? v) + (define-values (bulk-bindings end) + (let loop ([l (cdr v)] [bulk-bindings null]) + (cond + [(pair? l) + (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) + (decode-bulk-import (cdar l) ht)) + bulk-bindings))] + [else (values (reverse bulk-bindings) l)]))) + (set-scope-bulk-bindings! sc bulk-bindings) + (unless (and (vector? end) + (even? (vector-length end))) + (error 'decode-wrap "bad scope")) + (define bindings + (let loop ([i 0]) + (cond + [(= i (vector-length end)) null] + [else + (append (for/list ([p (in-list (vector-ref end (add1 i)))]) + (list (vector-ref end i) + (decode-scope-set (car p) ht) + (decode-binding (cdr p) ht))) + (loop (+ i 2)))]))) + (set-scope-bindings! sc bindings)) + sc))) + +(define (decode-scope-set l ht) + (decode-map decode-scope l ht)) + +(define (decode-binding b ht) + (hash-ref! ht b + (lambda () + (match b + [(box (cons base-b (cons sym wraps))) + (free-id=?-binding + (decode-binding base-b ht) + (stx-obj sym wraps 'clean))] + [(? symbol?) + (local-binding b)] + [else + ;; Leave it encoded, so that the compactness (or not) + ;; of the encoding is visible; clients decode further + ;; with `decode-module-binding` + (module-binding b)])))) + +(define (decode-module-binding b name) + (define-values (insp-desc rest-b) + (match b + [(cons (? symbol?) _) + (values (car b) (cdr b))] + [else + (values #f b)])) + (define (decode-nominal-modidx-plus-phase n mod-phase) + (match n + [(? module-path-index?) + (values n mod-phase 0)] + [(cons nom-modix (cons import-phase nom-phase)) + (values nom-modix nom-phase import-phase)] + [(cons nom-modix import-phase) + (values nom-modix mod-phase import-phase)] + [_ + (error 'decode-module-binding "bad encoding")])) + (match rest-b + [(and modidx (? module-path-index?)) + (decoded-module-binding modidx name 0 + modidx name 0 + 0 insp-desc)] + [(cons (and modidx (? module-path-index?)) + (and name (? symbol?))) + (decoded-module-binding modidx name 0 + modidx name 0 + 0 insp-desc)] + [(cons (and modidx (? module-path-index?)) + (and nom-modidx (? module-path-index?))) + (decoded-module-binding modidx name 0 + nom-modidx name 0 + 0 insp-desc)] + [(list* modidx (and name (? symbol?)) + nominal-modidx-plus-phase nom-name) + (define-values (nom-modidx nom-phase import-phase) + (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase 0)) + (decoded-module-binding modidx name 0 + nom-modidx nom-name nom-phase + import-phase insp-desc)] + [(list* modidx mod-phase (and name (? symbol?)) + nominal-modidx-plus-phase nom-name) + (define-values (nom-modidx nom-phase import-phase) + (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase mod-phase)) + (decoded-module-binding modidx name mod-phase + nom-modidx nom-name nom-phase + import-phase insp-desc)] + [_ (error 'decode-module-binding "bad encoding")])) + +(define (decode-bulk-import l ht) + (hash-ref! ht l + (lambda () + (match l + [(vector (and modidx (? module-path-index?)) + src-phase + info + (and insp-desc (or #f (? symbol?)))) + (define-values (phase prefix excepts) + (match info + [(or #f (? exact-integer?)) + (values info #f '#())] + [(cons phase (and prefix (? symbol?))) + (values phase prefix '#())] + [(cons phase (cons excepts prefix)) + (values phase prefix excepts)] + [(cons phase excepts) + (values phase #f excepts)] + [_ (error 'decode-wrap "bad bulk import info")])) + (all-from-module modidx + phase + src-phase + insp-desc + (if excepts + (vector->list excepts) + null) + prefix)] + [_ (error 'decode-wrap "bad bulk import")])))) + +(define (decode-shifted-multi-scope sms ht) + (unless (pair? sms) + (error 'decode-wrap "bad multi-scope pair")) + (list (decode-multi-scope (car sms) ht) + (cdr sms))) + +(define (decode-multi-scope ms ht) + (unless (and (vector? ms) + (odd? (vector-length ms))) + (error 'decode-wrap "bad multi scope")) + (hash-ref ht ms + (lambda () + (define multi (multi-scope (hash-count ht) + (vector-ref ms (sub1 (vector-length ms))) + null)) + (hash-set! ht ms multi) + (define scopes + (let loop ([i 0]) + (cond + [(= (add1 i) (vector-length ms)) null] + [else + (define s (decode-scope (vector-ref ms (add1 i)) ht)) + (when (scope-multi-owner s) + (error 'decode-wrap "bad scope owner: ~e while reading ~e" + (scope-multi-owner s) + multi)) + (set-scope-multi-owner! s multi) + (cons (list (vector-ref ms i) + s) + (loop (+ i 2)))]))) + (set-multi-scope-scopes! multi scopes) + multi))) ;; ---------------------------------------- diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index d6f9e19ff5..c1b83b3478 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -20,12 +20,12 @@ ;; ---------------------------------------- ;; Structures to represent bytecode -(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) +(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract . options] ...)) (begin - (define-struct id+par (field-id ...) #:prefab) - #;(provide (struct-out id)) - (provide/contract - [struct id ([field-id field-contract] ...)]))) + (define-struct id+par ([field-id . options] ...) #:prefab) + (provide + (contract-out + [struct id ([field-id field-contract] ...)])))) (define-struct zo () #:prefab) (provide (struct-out zo)) @@ -58,30 +58,9 @@ function-shape? struct-shape?)])) -;; Syntax object -(define ((alist/c k? v?) l) - (let loop ([l l]) - (match l - [(list) #t] - [(list* (? k?) (? v?) l) - (loop l)] - [_ #f]))) - -(define mark-map? - (alist/c number? module-path-index?) - #;(hash/c number? module-path-index?)) - -(define-form-struct wrap ()) -(define-form-struct wrapped ([datum any/c] - [wraps any/c] - [tamper-status (or/c 'clean 'armed 'tainted)])) - -;; In stxs of prefix: -(define-form-struct stx ([encoded wrapped?])) - (define-form-struct prefix ([num-lifts exact-nonnegative-integer?] [toplevels (listof (or/c #f symbol? global-bucket? module-variable?))] - [stxs list?] ; should be (listof stx?) sets up top-level and syntax-object array + [stxs (listof (or/c #f stx?))] ; #f is unusual, but it can happen when one is optimized away at the last moment [src-inspector-desc symbol?])) (define-form-struct form ()) @@ -196,55 +175,52 @@ ;; Top-level `require' (define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) + +;; Syntax objects + +(define-form-struct stx ([content stx-obj?])) + +(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components + [wrap any/c] ; shuold be `wrap?`, but encoded form appears initially + [tamper-status (or/c 'clean 'armed 'tainted)])) + +(define-form-struct wrap ([shifts (listof module-shift?)] + [simple-scopes (listof scope?)] + [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))])) + +(define-form-struct module-shift ([from (or/c #f module-path-index?)] + [to (or/c #f module-path-index?)] + [from-inspector-desc (or/c #f symbol?)] + [to-inspector-desc (or/c #f symbol?)])) + +(define-form-struct scope ([name (or/c 'root exact-nonnegative-integer?)] ; 'root is special; otherwise, just for printing + [kind symbol?] + [bindings (listof (list/c symbol? (listof scope?) binding?)) #:mutable] + [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #:mutable] + [multi-owner (or/c #f multi-scope?) #:mutable])) +(define-form-struct multi-scope ([name exact-nonnegative-integer?] + [src-name any/c] ; debugging info, such as module name + [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #:mutable])) + +(define-form-struct binding ()) +(define-form-struct (free-id=?-binding binding) ([base (and/c binding? + (not/c free-id=?-binding?))] + [id stx-obj?])) +(define-form-struct (local-binding binding) ([name symbol?])) +(define-form-struct (module-binding binding) ([encoded any/c])) +;; Convert `module-binding` to `decoded-module-binding` with `decode-module-binding`: +(define-form-struct (decoded-module-binding binding) ([path (or/c #f module-path-index?)] + [name symbol?] + [phase exact-integer?] + [nominal-path (or/c #f module-path-index?)] + [nominal-export-name symbol?] + [nominal-phase (or/c #f exact-integer?)] + [import-phase (or/c #f exact-integer?)] + [inspector-desc (or/c #f symbol?)])) + (define-form-struct all-from-module ([path module-path-index?] [phase (or/c exact-integer? #f)] [src-phase (or/c exact-integer? #f)] + [inspector-desc symbol?] [exceptions (listof symbol?)] - [prefix (or/c symbol? #f)] - [context (or/c (listof exact-integer?) - (vector/c (listof exact-integer?) any/c))])) - -(define-form-struct nominal-path ()) -(define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?])) -(define-form-struct (imported-nominal-path nominal-path) ([value module-path-index?] - [import-phase exact-integer?])) -(define-form-struct (phased-nominal-path nominal-path) ([value module-path-index?] - [import-phase (or/c false/c exact-integer?)] - [phase exact-integer?])) - -(define-form-struct module-binding ()) -(define-form-struct (phased-module-binding module-binding) ([path module-path-index?] - [phase exact-integer?] - [export-name any/c] - [nominal-path nominal-path?] - [nominal-export-name any/c])) -(define-form-struct (exported-nominal-module-binding module-binding) ([path module-path-index?] - [export-name any/c] - [nominal-path nominal-path?] - [nominal-export-name any/c])) -(define-form-struct (nominal-module-binding module-binding) ([path module-path-index?] - [nominal-path nominal-path?])) -(define-form-struct (exported-module-binding module-binding) ([path module-path-index?] - [export-name any/c])) -(define-form-struct (simple-module-binding module-binding) ([path module-path-index?])) - -(define-form-struct (module-rename wrap) ([phase (or/c exact-integer? #f)] - [kind (or/c 'marked 'normal)] - [set-id any/c] - [unmarshals (listof all-from-module?)] - [renames (listof (cons/c symbol? module-binding?))] - [mark-renames any/c] - [plus-kern? boolean?])) - -; XXX better name for 'flag' -(define-form-struct (top-level-rename wrap) ([flag boolean?])) - -; XXX better name for 'value' -(define-form-struct (mark-barrier wrap) ([value symbol?])) - - - - - - - + [prefix (or/c symbol? #f)])) From 8e617a6e5b366ad94fd7975769208b250f44b64b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Apr 2015 06:04:48 -0600 Subject: [PATCH 422/466] =?UTF-8?q?fix=20decoding=20of=20`free-identifier?= =?UTF-8?q?=3D=3F`=20alias=20information?= --- zo-lib/compiler/zo-marshal.rkt | 12 +++++++----- zo-lib/compiler/zo-parse.rkt | 5 +++-- zo-lib/compiler/zo-structs.rkt | 3 ++- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 6c4e657a3d..10f11c0b70 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -1307,17 +1307,19 @@ (define (encode-binding b name ht) (match b - [(free-id=?-binding base id) + [(free-id=?-binding base id phase) (hash-ref ht b (lambda () (match b - [(free-id=?-binding base id) + [(free-id=?-binding base id phase) (define bx (box #f)) (hash-set! ht b bx) (set-box! bx - (cons (encode-binding base name ht) - (cons (stx-obj-datum id) - (stx-obj-wrap id))))])))] + (cons + (cons (encode-binding base name ht) + (cons (stx-obj-datum id) + (stx-obj-wrap id))) + phase))])))] [_ (hash-ref! ht b (lambda () diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index dc53a5bc75..9c411c323f 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -1298,10 +1298,11 @@ (hash-ref! ht b (lambda () (match b - [(box (cons base-b (cons sym wraps))) + [(box (cons base-b (cons (cons sym wraps) phase))) (free-id=?-binding (decode-binding base-b ht) - (stx-obj sym wraps 'clean))] + (stx-obj sym (decode-wrap wraps ht) 'clean) + phase)] [(? symbol?) (local-binding b)] [else diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index c1b83b3478..68af6f58e4 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -205,7 +205,8 @@ (define-form-struct binding ()) (define-form-struct (free-id=?-binding binding) ([base (and/c binding? (not/c free-id=?-binding?))] - [id stx-obj?])) + [id stx-obj?] + [phase (or/c #f exact-integer?)])) (define-form-struct (local-binding binding) ([name symbol?])) (define-form-struct (module-binding binding) ([encoded any/c])) ;; Convert `module-binding` to `decoded-module-binding` with `decode-module-binding`: From c431d349550fcedc1d67cdac7fbadbfa7aace24e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 10 Apr 2015 20:41:39 -0600 Subject: [PATCH 423/466] repair to decompiler printing of eq hash tables --- compiler-lib/compiler/decompile.rkt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index cde92e1104..3c80c7a2f0 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -112,7 +112,12 @@ (define ph (make-placeholder #f)) (hash-set! ht e ph) (placeholder-set! ph - (make-hash-placeholder + ((cond + [(hash-eq? ht) + make-hasheq-placeholder] + [(hash-eqv? ht) + make-hasheqv-placeholder] + [else make-hash-placeholder]) (for/list ([(k v) (in-hash e)]) (cons (loop k) (loop v))))) ph] From 6933512ec26f61695b88879c601080e5ddd02d6a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Jul 2015 13:29:15 -0600 Subject: [PATCH 424/466] update for revised bytecode --- zo-lib/compiler/zo-parse.rkt | 17 ++++++++++++++--- zo-lib/info.rkt | 2 +- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 9c411c323f..e21dd455e2 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -1265,9 +1265,19 @@ null #f)) (hash-set! ht s sc) - (unless (number? v) + (define bindings-l + (if (= kind 1) ; has multi owner + (match v + [(cons (? number?) (cons multi bindings-l)) + (set-scope-multi-owner! sc (decode-multi-scope multi ht)) + bindings-l]) + (match v + [(? number?) #f] + [(cons (? number?) bindings-l) + bindings-l]))) + (when bindings-l (define-values (bulk-bindings end) - (let loop ([l (cdr v)] [bulk-bindings null]) + (let loop ([l bindings-l] [bulk-bindings null]) (cond [(pair? l) (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) @@ -1410,7 +1420,8 @@ [(= (add1 i) (vector-length ms)) null] [else (define s (decode-scope (vector-ref ms (add1 i)) ht)) - (when (scope-multi-owner s) + (when (and (scope-multi-owner s) + (not (eq? (scope-multi-owner s) multi))) (error 'decode-wrap "bad scope owner: ~e while reading ~e" (scope-multi-owner s) multi)) diff --git a/zo-lib/info.rkt b/zo-lib/info.rkt index b6e36644e7..fc36b36f5a 100644 --- a/zo-lib/info.rkt +++ b/zo-lib/info.rkt @@ -2,7 +2,7 @@ (define collection 'multi) -(define deps '("base")) +(define deps '(["base" #:version "6.2.900.5"])) (define pkg-desc "Libraries for handling zo files") From a10e570edd441f9c6e9dfba6362b5028f58f394c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Jul 2015 10:53:30 -0600 Subject: [PATCH 425/466] tests for submodules+source It happens that an old test also covers submodules+collects-dest, due to a change in a module implementation to refer to a submodule. --- .../tests/compiler/embed/embed-me25.rkt | 9 ++ .../tests/compiler/embed/embed-me26.rkt | 10 ++ .../tests/compiler/embed/embed-me27.rkt | 3 + compiler-test/tests/compiler/embed/test.rkt | 92 +++++++++++++------ 4 files changed, 87 insertions(+), 27 deletions(-) create mode 100644 compiler-test/tests/compiler/embed/embed-me25.rkt create mode 100644 compiler-test/tests/compiler/embed/embed-me26.rkt create mode 100644 compiler-test/tests/compiler/embed/embed-me27.rkt diff --git a/compiler-test/tests/compiler/embed/embed-me25.rkt b/compiler-test/tests/compiler/embed/embed-me25.rkt new file mode 100644 index 0000000000..59d7f600a9 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me25.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(module+ main + 12) + +(module submod racket/base + 11) + +10 diff --git a/compiler-test/tests/compiler/embed/embed-me26.rkt b/compiler-test/tests/compiler/embed/embed-me26.rkt new file mode 100644 index 0000000000..979fe8ec32 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me26.rkt @@ -0,0 +1,10 @@ +#lang racket/base + +(module+ main + 12) + +(module submod racket/base + 11) + +10 +(require (submod "embed-me27.rkt" other-submod)) diff --git a/compiler-test/tests/compiler/embed/embed-me27.rkt b/compiler-test/tests/compiler/embed/embed-me27.rkt new file mode 100644 index 0000000000..6db0fbf611 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me27.rkt @@ -0,0 +1,3 @@ +#lang racket/base + +(module+ other-submod 'y) diff --git a/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt index ab22506563..ef67538317 100644 --- a/compiler-test/tests/compiler/embed/test.rkt +++ b/compiler-test/tests/compiler/embed/test.rkt @@ -267,7 +267,6 @@ (define (try-basic) (mz-tests #f) (mz-tests #t) - (begin (prepare mr-dest "embed-me5.rkt") (make-embedding-executable @@ -288,11 +287,15 @@ "raco.exe" "raco"))) +(define (system+ . args) + (printf "> ~a\n" (car (reverse args))) + (apply system* args)) + (define (short-mzc-tests mred?) (parameterize ([current-directory (find-system-path 'temp-dir)]) ;; raco exe - (system* raco + (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") @@ -300,7 +303,7 @@ (try-exe (mk-dest mred?) "This is 1\n" mred?) ;; raco exe on a module with a `main' submodule - (system* raco + (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") @@ -312,7 +315,7 @@ (parameterize ([current-directory (find-system-path 'temp-dir)]) ;; raco exe - (system* raco + (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") @@ -320,7 +323,7 @@ (try-exe (mk-dest mred?) "This is 1\n" mred?) ;; raco exe on a module with a `main' submodule - (system* raco + (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") @@ -328,7 +331,7 @@ (try-exe (mk-dest mred?) "This is 16.\n" mred?) ;; raco exe on a module with a `main' submodule+ - (system* raco + (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") @@ -336,7 +339,7 @@ (try-exe (mk-dest mred?) "This is 20.\n" mred?) ;; raco exe on a module with a `configure-runtime' submodule - (system* raco + (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") @@ -344,7 +347,7 @@ (try-exe (mk-dest mred?) "Configure!\nThis is 22.\n" mred?) ;; raco exe on a module with serialization - (system* raco + (system+ raco "exe" "-o" (path->string (mk-dest mred?)) (if mred? "--gui" "--") @@ -352,7 +355,7 @@ (try-exe (mk-dest mred?) "1\n2\n" mred?) ;; raco exe --launcher - (system* raco + (system+ raco "exe" "--launcher" "-o" (path->string (mk-dest mred?)) @@ -362,7 +365,7 @@ ;; the rest use mzc... - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me1.rkt"))) @@ -371,7 +374,7 @@ (define (check-collection-path prog lib in-main?) ;; Check that etc.rkt isn't found if it's not included: (printf ">>not included\n") - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string (build-path (collection-path "tests" "compiler" "embed") prog))) @@ -379,7 +382,7 @@ ;; And it is found if it is included: (printf ">>included\n") - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "++lib" lib @@ -388,7 +391,7 @@ ;; Or, it's found if we set the collection path: (printf ">>set coll path\n") - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "--collects-path" @@ -400,7 +403,7 @@ ;; Or, it's found if we set the collection path and the config path (where the latter ;; finds links for packages): (printf ">>set coll path plus config\n") - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "--collects-path" @@ -413,7 +416,7 @@ ;; Try --collects-dest mode (printf ">>--collects-dest\n") - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) "++lib" lib @@ -423,7 +426,7 @@ (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (parameterize ([current-error-port (open-output-nowhere)]) - (test #f system* (mk-dest mred?)))) + (test #f system+ (mk-dest mred?)))) (check-collection-path "embed-me6b.rkt" "racket/fixnum.rkt" #t) (check-collection-path "embed-me6.rkt" "mzlib/etc.rkt" ;; "mzlib" is found via the "collects" path @@ -464,11 +467,11 @@ (make-directory* ext-dir) - (system* mzc + (system+ mzc "--cc" "-d" (path->string (path-only obj-file)) (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me8.c"))) - (system* mzc + (system+ mzc "--ld" (path->string ext-file) (path->string obj-file)) @@ -478,7 +481,7 @@ (copy-file (build-path (collection-path "tests" "compiler" "embed") "embed-me9.rkt") ss-file) - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string ss-file)) @@ -489,7 +492,7 @@ (delete-directory/files ext-base-dir))) ;; openssl, which needs extra binaries under Windows - (system* mzc + (system+ mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me10.rkt"))) @@ -502,7 +505,7 @@ (define (try-gracket) ;; A GRacket-specific test with mzc: (parameterize ([current-directory (find-system-path 'temp-dir)]) - (system* mzc + (system+ mzc "--gui-exe" (path->string (mk-dest #t)) (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me5.rkt"))) @@ -557,14 +560,46 @@ ;; ---------------------------------------- +(define (try-source) + (define (try-one file submod start result) + (define mred? #f) + (define dest (mk-dest mred?)) + + (printf "> ~a ~s from source\n" file submod) + (create-embedding-executable + dest + #:modules `((#%mzc: ,(collection-file-path file "tests/compiler/embed") ,submod)) + #:configure-via-first-module? #t + #:literal-expression + (parameterize ([current-namespace (make-base-namespace)]) + (compile + `(begin + (namespace-require ',start)))) + #:src-filter (lambda (p) (or (equal? p (collection-file-path "embed-me25.rkt" "tests/compiler/embed")) + (equal? p (collection-file-path "embed-me26.rkt" "tests/compiler/embed")) + (equal? p (collection-file-path "embed-me27.rkt" "tests/compiler/embed")))) + #:get-extra-imports (lambda (src mod) + (list 'racket/base/lang/reader))) + + (try-exe dest result mred?)) + + (try-one "embed-me25.rkt" null ''|#%mzc:embed-me25| "10\n") + (try-one "embed-me25.rkt" '(main) '(submod '|#%mzc:embed-me25| main) "10\n12\n") + (try-one "embed-me25.rkt" '(submod) '(submod '|#%mzc:embed-me25| submod) "11\n") + (try-one "embed-me26.rkt" null ''|#%mzc:embed-me26| "'y\n10\n") + (try-one "embed-me26.rkt" '(submod) '(submod '|#%mzc:embed-me26| submod) "11\n") + (try-one "embed-me26.rkt" '(main) '(submod '|#%mzc:embed-me26| main) "'y\n10\n12\n")) + +;; ---------------------------------------- + (define planet (build-path (find-console-bin-dir) (if (eq? 'windows (system-type)) "planet.exe" "planet"))) (define (try-planet) - (system* raco "planet" "link" "racket-tester" "p1.plt" "1" "0" + (system+ raco "planet" "link" "racket-tester" "p1.plt" "1" "0" (path->string (collection-path "tests" "compiler" "embed" "embed-planet-1"))) - (system* raco "planet" "link" "racket-tester" "p2.plt" "2" "2" + (system+ raco "planet" "link" "racket-tester" "p2.plt" "2" "2" (path->string (collection-path "tests" "compiler" "embed" "embed-planet-2"))) (let ([go (lambda (path expected) @@ -575,7 +610,7 @@ #:exists 'truncate (lambda () (printf "#lang racket/base (require ~s)\n" path))) - (system* mzc "--exe" (path->string dest) (path->string tmp)) + (system+ mzc "--exe" (path->string dest) (path->string tmp)) (try-exe dest expected #f) (delete-directory/files dest) @@ -597,8 +632,8 @@ (void)) - (system* raco "planet" "unlink" "racket-tester" "p1.plt" "1" "0") - (system* raco "planet" "unlink" "racket-tester" "p2.plt" "2" "2")) + (system+ raco "planet" "unlink" "racket-tester" "p1.plt" "1" "0") + (system+ raco "planet" "unlink" "racket-tester" "p2.plt" "2" "2")) ;; ---------------------------------------- @@ -606,7 +641,7 @@ (define (try-one src) (printf "Trying ~a...\n" src) (define exe (path->string (mk-dest #f))) - (system* raco + (system+ raco "exe" "-o" exe "--" @@ -621,6 +656,7 @@ ;; ---------------------------------------- +#| REMOVEME (try-basic) (try-mzc) (try-extension) @@ -628,6 +664,8 @@ (try-reader) (try-planet) (try-*sl) +|# +(try-source) ;; ---------------------------------------- ;; Make sure that embedding does not break future module declarations From 03751ec33a32a6cd6e940aa1a84c6f512f6029ca Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Jul 2015 20:26:31 -0600 Subject: [PATCH 426/466] Revert "update for revised bytecode" This reverts commit 6933512ec26f61695b88879c601080e5ddd02d6a. The bytecode-format change was reverted. --- zo-lib/compiler/zo-parse.rkt | 17 +++-------------- zo-lib/info.rkt | 2 +- 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index e21dd455e2..9c411c323f 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -1265,19 +1265,9 @@ null #f)) (hash-set! ht s sc) - (define bindings-l - (if (= kind 1) ; has multi owner - (match v - [(cons (? number?) (cons multi bindings-l)) - (set-scope-multi-owner! sc (decode-multi-scope multi ht)) - bindings-l]) - (match v - [(? number?) #f] - [(cons (? number?) bindings-l) - bindings-l]))) - (when bindings-l + (unless (number? v) (define-values (bulk-bindings end) - (let loop ([l bindings-l] [bulk-bindings null]) + (let loop ([l (cdr v)] [bulk-bindings null]) (cond [(pair? l) (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) @@ -1420,8 +1410,7 @@ [(= (add1 i) (vector-length ms)) null] [else (define s (decode-scope (vector-ref ms (add1 i)) ht)) - (when (and (scope-multi-owner s) - (not (eq? (scope-multi-owner s) multi))) + (when (scope-multi-owner s) (error 'decode-wrap "bad scope owner: ~e while reading ~e" (scope-multi-owner s) multi)) diff --git a/zo-lib/info.rkt b/zo-lib/info.rkt index fc36b36f5a..b6e36644e7 100644 --- a/zo-lib/info.rkt +++ b/zo-lib/info.rkt @@ -2,7 +2,7 @@ (define collection 'multi) -(define deps '(["base" #:version "6.2.900.5"])) +(define deps '("base")) (define pkg-desc "Libraries for handling zo files") From b3887f37d38cea310223ae8b7c2732b8cc38587d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 23 Jul 2015 07:46:28 -0600 Subject: [PATCH 427/466] fill in some missing sharing Make `zo-marshal` consistent with `racket`, so that round-trip testing works. --- zo-lib/compiler/zo-marshal.rkt | 45 ++++++++++++++-------------------- 1 file changed, 18 insertions(+), 27 deletions(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 10f11c0b70..59db7ca70a 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -152,12 +152,12 @@ ; (obj -> (or pos #f)) output-port -> number ; writes top to outp using shared-obj-pos to determine symref ; returns the file position at the end of the compilation top - (define (out-compilation-top shared-obj-pos shared-obj-unsee outp) + (define (out-compilation-top shared-obj-pos shared-obj-unsee counting? outp) (define ct (match top [(compilation-top max-let-depth prefix form) (list* max-let-depth prefix (protect-quote form))])) - (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee + (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee counting? stx-objs wraps hash-consed)) (file-position outp)) @@ -205,6 +205,7 @@ (encounter! v)])) (λ (v) (unencounter! v)) + #t (open-output-nowhere)) (define symbol-table (make-vector (hash-count shared) (not-ready))) @@ -232,14 +233,14 @@ [i (in-naturals)]) (begin0 (file-position outp) - (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void #f stx-objs wraps hash-consed)))) (file-position outp))) ; Calculate file positions (define counting-port (open-output-nowhere)) (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) - (define all-forms-length (out-compilation-top shared-obj-pos void counting-port)) + (define all-forms-length (out-compilation-top shared-obj-pos void #f counting-port)) ; Write the compiled form header (write-bytes #"#~" outp) @@ -267,7 +268,7 @@ (write-bytes (int->bytes all-forms-length) outp) ; Actually write the zo (out-symbol-table symbol-table outp) - (out-compilation-top shared-obj-pos void outp) + (out-compilation-top shared-obj-pos void #f outp) (void)) ;; ---------------------------------------- @@ -435,7 +436,7 @@ [(tainted) (vector p)] [(armed) (vector p #f)]))])) -(define-struct out (s shared-index shared-unsee stx-objs wraps hash-consed)) +(define-struct out (s shared-index shared-unsee counting? stx-objs wraps hash-consed)) (define (out-shared v out k) (if (shareable? v) (let ([v ((out-shared-index out) v)]) @@ -802,28 +803,23 @@ (out-byte CPT_BOX out) (out-anything (unbox v) out)] [(? pair?) - ; This code will not turn two different lists that share a common tail - ; e.g. (list* 1 l) and (list* 2 l) - ; into a form that puts l into the symbol table - ; (when that is possible) - - ; In contrast, if we always use CPT_PAIR, then it would - - ; Unfortunately, detecting this situation during the traversal - ; phase, without introducing false sharing, is difficult. - ; We had an implementation (see the history), but it was buggy. (define (list-length-before-cycle/improper-end l) - (let loop ([len 0] [l l] [seen (set)]) + (let loop ([len 0] [l l]) (cond - [(set-member? seen l) - (values len #f)] [(null? l) (values len #t)] [(pair? l) - (loop (add1 len) (cdr l) (set-add seen l))] + (if ((out-shared-index out) l) + (values len #f) + (loop (add1 len) (cdr l)))] [else (values len #f)]))) - (define-values (len proper?) (list-length-before-cycle/improper-end v)) + + (define-values (len-1 proper?) + (if (out-counting? out) + (values 0 #f) + (list-length-before-cycle/improper-end (cdr v)))) + (define len (add1 len-1)) (define (print-contents-as-proper) (for ([e (in-list v)]) @@ -884,11 +880,6 @@ (out-anything (module-path-index-submodule v) out)))] [(stx content) (out-byte CPT_STX out) - ;; The core Racket printer currently records more sharing - ;; by ensureing that list tails are shared, while the printer - ;; here detects sharing only at the start of a list. That - ;; doesn't seem to matter much. Meanwhile, we ensure that - ;; as much sharing as possible is present before printing. (out-anything content out)] [(encoded-scope content) (out-byte CPT_SCOPE out) @@ -898,7 +889,7 @@ (out-number pos out)) (out-anything (share-everywhere content out) out)] [(? stx-obj?) - (out-anything (lookup-encoded-stx-obj v out) out)] + (out-anything (share-everywhere (lookup-encoded-stx-obj v out) out) out)] [(? prefab-struct-key) (define pre-v (struct->vector v)) (vector-set! pre-v 0 (prefab-struct-key v)) From efbd424ec0e6a6b1e91c5df67c58a9885f28bbb3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 28 Jul 2015 14:19:32 -0600 Subject: [PATCH 428/466] Add test-include-paths and allow test-omit-paths to use regexps --- compiler-lib/compiler/commands/test.rkt | 45 ++++++++++++------- .../test/extensions/a-omit-1.racket-file | 4 ++ .../compiler/test/extensions/a-omit-1.rkt | 4 ++ .../test/extensions/b-include-1.racket-file | 5 +++ .../compiler/test/extensions/b-include-1.rkt | 5 +++ .../tests/compiler/test/extensions/info.rkt | 3 ++ 6 files changed, 51 insertions(+), 15 deletions(-) create mode 100644 compiler-test/tests/compiler/test/extensions/a-omit-1.racket-file create mode 100644 compiler-test/tests/compiler/test/extensions/a-omit-1.rkt create mode 100644 compiler-test/tests/compiler/test/extensions/b-include-1.racket-file create mode 100644 compiler-test/tests/compiler/test/extensions/b-include-1.rkt create mode 100644 compiler-test/tests/compiler/test/extensions/info.rkt diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index b927636c40..1458f23499 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -558,9 +558,10 @@ #:sema continue-sema)))] [(and (or (not check-suffix?) (regexp-match rx:default-suffixes p) - (get-cmdline p #f #:check-info? #t)) + (get-cmdline p #f #:check-info? #t) + (include-path? p #:check-info? #t)) (or (not check-suffix?) - (not (omit-path? p #:check-info? #t)))) + (not (omit-path? p #:check-info? #t)))) (unless check-suffix? ;; make sure "info.rkt" information is loaded: (check-info p)) @@ -740,6 +741,7 @@ ;; Reading "info.rkt" files (define omit-paths (make-hash)) +(define include-paths (make-hash)) (define command-line-arguments (make-hash)) (define timeouts (make-hash)) (define lock-names (make-hash)) @@ -773,14 +775,22 @@ (hash-set! table dir #t)] [(list? v) (for ([i (in-list v)]) - (unless (path-string? i) (bad what v)) - (define p (normalize-info-path (path->complete-path i dir))) - (define dp (if (directory-exists? p) - (path->directory-path p) - p)) - (hash-set! table dp #t))] + (cond + [(path-string? i) + (define p (normalize-info-path (path->complete-path i dir))) + (define dp (if (directory-exists? p) + (path->directory-path p) + p)) + (hash-set! table dp #t)] + [(regexp? i) + (for ([f (in-directory dir)] + #:when (regexp-match i (path->string f))) + (hash-set! table f #t))] + [else + (bad what v)]))] [else (bad what v)])) (get-members omit-paths 'test-omit-paths #t) + (get-members include-paths 'test-include-paths #t) (get-members randoms 'test-randoms #t) (define (get-keyed table what check? #:ok-all? [ok-all? #f]) @@ -845,13 +855,18 @@ (define (normalize-info-path p) (simplify-path (path->complete-path p) #f)) -(define (omit-path? p #:check-info? [check-info? #f]) - (when check-info? (check-info p)) - (let ([p (normalize-info-path p)]) - (or (hash-ref omit-paths p #f) - (let-values ([(base name dir?) (split-path p)]) - (and (path? base) - (omit-path? base)))))) +(define (make-omit-path? omit-paths) + (define (omit-path? p #:check-info? [check-info? #f]) + (when check-info? (check-info p)) + (let ([p (normalize-info-path p)]) + (or (hash-ref omit-paths p #f) + (let-values ([(base name dir?) (split-path p)]) + (and (path? base) + (omit-path? base)))))) + omit-path?) + +(define omit-path? (make-omit-path? omit-paths)) +(define include-path? (make-omit-path? include-paths)) (define (get-cmdline p [default null] #:check-info? [check-info? #f]) (when check-info? (check-info p)) diff --git a/compiler-test/tests/compiler/test/extensions/a-omit-1.racket-file b/compiler-test/tests/compiler/test/extensions/a-omit-1.racket-file new file mode 100644 index 0000000000..46347b55a1 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/a-omit-1.racket-file @@ -0,0 +1,4 @@ +#lang racket/base +(error 'bad) +(module+ test + (error 'bad)) diff --git a/compiler-test/tests/compiler/test/extensions/a-omit-1.rkt b/compiler-test/tests/compiler/test/extensions/a-omit-1.rkt new file mode 100644 index 0000000000..46347b55a1 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/a-omit-1.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(error 'bad) +(module+ test + (error 'bad)) diff --git a/compiler-test/tests/compiler/test/extensions/b-include-1.racket-file b/compiler-test/tests/compiler/test/extensions/b-include-1.racket-file new file mode 100644 index 0000000000..5e2f56f1f0 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/b-include-1.racket-file @@ -0,0 +1,5 @@ +#lang racket/base +(define (f x) x) +(module+ test + (require rackunit) + (check-equal? (f 1) 1)) diff --git a/compiler-test/tests/compiler/test/extensions/b-include-1.rkt b/compiler-test/tests/compiler/test/extensions/b-include-1.rkt new file mode 100644 index 0000000000..5e2f56f1f0 --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/b-include-1.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(define (f x) x) +(module+ test + (require rackunit) + (check-equal? (f 1) 1)) diff --git a/compiler-test/tests/compiler/test/extensions/info.rkt b/compiler-test/tests/compiler/test/extensions/info.rkt new file mode 100644 index 0000000000..572ef689aa --- /dev/null +++ b/compiler-test/tests/compiler/test/extensions/info.rkt @@ -0,0 +1,3 @@ +#lang info +(define test-omit-paths '(#rx".*omit.*")) +(define test-include-paths '(#rx".*include.*")) From cb1c9aabe6731c624e01cb45084b456c1edef828 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 29 Jul 2015 07:24:16 -0600 Subject: [PATCH 429/466] fix dependency --- compiler-test/info.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler-test/info.rkt b/compiler-test/info.rkt index c27205bdc7..225508f53c 100644 --- a/compiler-test/info.rkt +++ b/compiler-test/info.rkt @@ -14,5 +14,6 @@ "compatibility-lib" "gui-lib" "htdp-lib" - "plai-lib")) + "plai-lib" + "rackunit-lib")) (define update-implies '("compiler-lib")) From 92e9ac99f50125653b2f387d36b262688e71ad98 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 6 Aug 2015 15:11:39 -0600 Subject: [PATCH 430/466] update for `with-immediate-continuation-mark` and scope IDs --- compiler-lib/compiler/decompile.rkt | 11 +++++++++-- zo-lib/compiler/zo-marshal.rkt | 25 +++++++++++++++++-------- zo-lib/compiler/zo-parse.rkt | 29 ++++++++++++++++++----------- zo-lib/compiler/zo-structs.rkt | 5 ++++- 4 files changed, 48 insertions(+), 22 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 3c80c7a2f0..3d25c16e2b 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -184,8 +184,9 @@ (length toplevels) (length stxs) num-lifts) - (cons + (list* `(quote inspector ,src-insp-desc) + ;; `(quote tls ,toplevels) (map (lambda (stx id) `(define ,id ,(if stx `(#%decode-syntax @@ -487,6 +488,12 @@ [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack closed) ,(decompile-expr args-expr globs stack closed))] + [(struct with-immed-mark (key-expr val-expr body-expr)) + (let ([id (gensym 'cmval)]) + `(#%call-with-immediate-continuation-mark + ,(decompile-expr key-expr globs stack closed) + (lambda (,id) ,(decompile-expr body-expr globs (cons id stack) closed)) + ,(decompile-expr val-expr globs stack closed)))] [(struct seq (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack closed)))] @@ -540,7 +547,7 @@ ,@(if (not tl-map) '() (list - (for/list ([pos (in-set tl-map)]) + (for/list ([pos (in-list (sort (set->list tl-map) <))]) (define tl-pos (cond [(or (pos . < . (glob-desc-num-tls globs)) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 59db7ca70a..2a90ca01fd 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -20,7 +20,7 @@ (struct not-ready ()) -(struct encoded-scope ([content #:mutable]) #:prefab) +(struct encoded-scope (relative-id [content #:mutable]) #:prefab) (define (zo-marshal top) (define bs (open-output-bytes)) @@ -291,11 +291,12 @@ (define require-form-type-num 22) (define varref-form-type-num 23) (define apply-values-type-num 24) -(define case-lambda-sequence-type-num 25) -(define module-type-num 26) -(define inline-variants-type-num 27) -(define variable-type-num 35) -(define prefix-type-num 120) +(define with-immed-mark-type-num 25) +(define case-lambda-sequence-type-num 26) +(define module-type-num 27) +(define inline-variants-type-num 28) +(define variable-type-num 36) +(define prefix-type-num 121) (define-syntax define-enum (syntax-rules () @@ -753,6 +754,13 @@ (cons (protect-quote proc) (protect-quote args-expr)) out)] + [(struct with-immed-mark (key val body)) + (out-marshaled with-immed-mark-type-num + (vector + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] [(struct with-cont-mark (key val body)) (out-marshaled wcm-type-num (list* @@ -881,12 +889,13 @@ [(stx content) (out-byte CPT_STX out) (out-anything content out)] - [(encoded-scope content) + [(encoded-scope relative-id content) (out-byte CPT_SCOPE out) ;; The `out-shared` wrapper already called `((out-shared-index out) v)` ;; once, so `pos` will defintely be a number: (let ([pos ((out-shared-index out) v)]) (out-number pos out)) + (out-number relative-id out) (out-anything (share-everywhere content out) out)] [(? stx-obj?) (out-anything (share-everywhere (lookup-encoded-stx-obj v out) out) out)] @@ -1229,7 +1238,7 @@ s (hash-ref ht s (lambda () - (define es (encoded-scope #f)) + (define es (encoded-scope (scope-name s) #f)) (hash-set! ht s es) (define kind (case (scope-kind s) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 9c411c323f..0d7b9ac55b 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -192,6 +192,8 @@ (make-varref (car v) (cdr v))) (define (read-apply-values v) (make-apply-values (car v) (cdr v))) +(define (read-with-immed-mark v) + (make-with-immed-mark (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) (define (read-splice v) (make-splice v)) @@ -372,12 +374,13 @@ [(22) 'require-form-type] [(23) 'varref-form-type] [(24) 'apply-values-type] - [(25) 'case-lambda-sequence-type] - [(26) 'module-type] - [(27) 'inline-variant-type] - [(35) 'variable-type] - [(36) 'module-variable-type] - [(120) 'resolve-prefix-type] + [(25) 'with-immed-mark-type] + [(26) 'case-lambda-sequence-type] + [(27) 'module-type] + [(28) 'inline-variant-type] + [(36) 'variable-type] + [(37) 'module-variable-type] + [(121) 'resolve-prefix-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers @@ -407,6 +410,7 @@ (cons 'require-form-type read-require) (cons 'varref-form-type read-#%variable-ref) (cons 'apply-values-type read-apply-values) + (cons 'with-immed-mark-type read-with-immed-mark) (cons 'splice-sequence-type read-splice)))) (define (get-reader type) @@ -592,7 +596,7 @@ (with-memo* mt arg (λ () body ...))) ;; placeholder for a `scope` decoded in a second pass: -(struct encoded-scope (content) #:prefab) +(struct encoded-scope (relative-id content) #:prefab) (define (decode-wrapped cp v) (let loop ([v v]) @@ -942,10 +946,13 @@ [(small-svector) (read-compact-svector cp (- ch cpt-start))] [(scope) - (let ([pos (read-compact-number cp)]) + (let ([pos (read-compact-number cp)] + [relative-id (read-compact-number cp)]) (if (zero? pos) - (encoded-scope (read-compact cp)) - (read-cyclic cp pos 'scope encoded-scope)))] + (encoded-scope relative-id (read-compact cp)) + (read-cyclic cp pos 'scope (lambda (v) + (encoded-scope relative-id + v)))))] [(root-scope) root-scope] [(shared) @@ -1254,7 +1261,7 @@ [(cons (? number?) _) (car v)] [else (error 'decode-wrap "bad scope")])) - (define sc (scope (hash-count ht) + (define sc (scope (encoded-scope-relative-id s) (case kind [(0 1) 'module] [(2) 'macro] diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index 68af6f58e4..5b83c6047a 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -170,6 +170,9 @@ (define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)] + [def-val (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive ;; Top-level `require' @@ -186,7 +189,7 @@ (define-form-struct wrap ([shifts (listof module-shift?)] [simple-scopes (listof scope?)] - [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))])) + [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))])) (define-form-struct module-shift ([from (or/c #f module-path-index?)] [to (or/c #f module-path-index?)] From 08a40b599808fca018c81b7b9683c4ff84ddd65b Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 25 Jun 2015 11:40:29 -0600 Subject: [PATCH 431/466] repair reference to "dummy" top level The demodularizer used to include multiple dummy toplevels from every module that needed one, which didn't work with the unresolver. That change makes it so all references to dummy toplevels point to the same one. --- compiler-lib/compiler/demodularizer/merge.rkt | 108 +++++++++++------- compiler-lib/compiler/demodularizer/nodep.rkt | 2 +- 2 files changed, 70 insertions(+), 40 deletions(-) diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt index 71202724f2..3aeeadd18e 100644 --- a/compiler-lib/compiler/demodularizer/merge.rkt +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -25,6 +25,9 @@ (log-debug (format "total toplevels ~S" total-tls)) (log-debug (format "total stxs ~S" total-stxs)) (log-debug (format "num-lifts ~S" total-lifts)) + (for ([i (in-naturals)] + [p (in-list (prefix-toplevels new-prefix))]) + (log-debug (format "new-prefix tls\t~v ~v" i p))) (make-compilation-top new-max-let-depth new-prefix (make-splice (gen-new-forms new-prefix)))] @@ -32,14 +35,14 @@ (define (merge-forms max-let-depth prefix forms) (if (empty? forms) - (values max-let-depth prefix (lambda _ empty)) - (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] - [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) - (values rmax-let-depth - rprefix - (lambda args - (append (apply gen-fform args) - (apply gen-rforms args))))))) + (values max-let-depth prefix (lambda _ empty)) + (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] + [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) + (values rmax-let-depth + rprefix + (lambda args + (append (apply gen-fform args) + (apply gen-rforms args))))))) (define (merge-form max-let-depth prefix form) (match form @@ -52,15 +55,19 @@ [else (values max-let-depth prefix (lambda _ (list form)))])) +(define (index-of v l) + (for/or ([e (in-list l)] + [i (in-naturals)] + #:when (eq? e v)) + i)) + (define (merge-prefix root-prefix mod-prefix) - (match root-prefix - [(struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) - (match mod-prefix - [(struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) - (make-prefix (+ root-num-lifts mod-num-lifts) - (append root-toplevels mod-toplevels) - (append root-stxs mod-stxs) - root-src-insp-desc)])])) + (match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix) + (match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix) + (make-prefix (+ root-num-lifts mod-num-lifts) + (append root-toplevels mod-toplevels) + (append root-stxs mod-stxs) + root-src-insp-desc)) (struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) @@ -73,22 +80,25 @@ (define tl (provide->toplevel sym pos)) (log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl)) (match-define (toplevel-offset-rewriter rewrite-fun meta) - (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx - (lambda () - (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) + (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda () + (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta)) (define res (rewrite-fun tl)) (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S" sym pos (mpi->path* modidx) tl meta res)) res])])) -(define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) +(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels) (define-values (i new-toplevels remap) (for/fold ([i 0] [new-toplevels empty] [remap empty]) - ([tl (in-list mod-toplevels)]) + ([tl (in-list mod-toplevels)] + [idx (in-naturals)]) + (log-debug (format "[~S] mod-prefix tls\t~v ~v" + name idx tl)) (match tl [(and mv (struct module-variable (modidx sym pos phase constantness))) (define rw ((current-get-modvar-rewrite) modidx)) @@ -96,7 +106,7 @@ (unless (or (not phase) (zero? phase)) (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) (cond - ; Primitive module like #%paramz + ; Primitive module like #%paramz [(symbol? rw) (log-debug (format "~S from ~S" sym rw)) (values (add1 i) @@ -113,10 +123,18 @@ [else (error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])] [tl - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))]))) - ; XXX This would be more efficient as a vector + (cond + [(and new-#f-idx (not tl)) + (log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v" + name idx (+ i toplevel-offset) new-#f-idx)) + (values i + new-toplevels + (list* new-#f-idx remap))] + [else + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))])]))) + ; XXX This would be more efficient as a vector (values (reverse new-toplevels) (reverse remap))) @@ -127,12 +145,18 @@ unexported mod-max-let-depth dummy lang-info internal-context binding-names flags pre-submodules post-submodules)) - (define toplevel-offset (length (prefix-toplevels top-prefix))) + (define top-toplevels (prefix-toplevels top-prefix)) + (define toplevel-offset (length top-toplevels)) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) (define mod-toplevels (prefix-toplevels mod-prefix)) + (define new-#f-idx + (index-of #f top-toplevels)) + (when new-#f-idx + (log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing" + name new-#f-idx))) (define-values (new-mod-toplevels toplevel-remap) - (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) + (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels)) (define num-mod-toplevels (length toplevel-remap)) (define mod-stxs @@ -177,17 +201,23 @@ (define update (update-toplevels (lambda (n) - (cond - [(mod-lift-start . <= . n) - ; This is a lift - (define which-lift (- n mod-lift-start)) - (define lift-tl (+ top-lift-start lift-offset which-lift)) - (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl] - [else - (list-ref toplevel-remap n)])) + (define new-idx + (cond + [(mod-lift-start . <= . n) + (log-debug (format "[~S] ~v is a lift" + name n)) + (define which-lift (- n mod-lift-start)) + (define lift-tl (+ top-lift-start lift-offset which-lift)) + (when (lift-tl . >= . max-toplevel) + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) + lift-tl] + [else + ;; xxx maybe change this to a vector after it is made to make this efficient + (list-ref toplevel-remap n)])) + (log-debug (format "[~S] ~v is remapped to ~v" + name n new-idx)) + new-idx) (lambda (n) (+ n topsyntax-offset)) (prefix-syntax-start top-prefix))) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index d1652826ff..d3741f5977 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -18,7 +18,7 @@ (define idx-map (make-hash)) (parameterize ([ZOS (make-hash)] [MODULE-IDX-MAP idx-map] - [PHASE*MODULE-CACHE (make-hash)]) + [PHASE*MODULE-CACHE (make-hasheq)]) (define (get-modvar-rewrite modidx) (define pth (mpi->path* modidx)) (hash-ref idx-map pth From d652ea0d52cc1e00565d13c5870877239f86329f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 10 Aug 2015 16:45:47 -0600 Subject: [PATCH 432/466] update demodularizer for recent bytecode changes --- compiler-lib/compiler/demodularizer/gc-toplevels.rkt | 3 +++ compiler-lib/compiler/demodularizer/module.rkt | 3 ++- compiler-lib/compiler/demodularizer/update-toplevels.rkt | 5 +++++ 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/compiler-lib/compiler/demodularizer/gc-toplevels.rkt b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt index a32f3857f1..ccdebc57ff 100644 --- a/compiler-lib/compiler/demodularizer/gc-toplevels.rkt +++ b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt @@ -124,6 +124,9 @@ [(struct with-cont-mark (key val body)) (for-each (lambda (f) (build-graph! lhs f)) (list key val body))] + [(struct with-immed-mark (key val body)) + (for-each (lambda (f) (build-graph! lhs f)) + (list key val body))] [(struct beg0 (seq)) (for-each (lambda (f) (build-graph! lhs f)) seq)] diff --git a/compiler-lib/compiler/demodularizer/module.rkt b/compiler-lib/compiler/demodularizer/module.rkt index f33b675008..6c7a3bc9c6 100644 --- a/compiler-lib/compiler/demodularizer/module.rkt +++ b/compiler-lib/compiler/demodularizer/module.rkt @@ -20,7 +20,7 @@ (map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs)) (make-compilation-top 0 - (make-prefix 0 (list #f) empty) + (make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix)) (make-mod name srcname self-modidx prefix @@ -33,6 +33,7 @@ (make-toplevel 0 0 #f #f) ; dummy lang-info #t + (hash) ; no names visible via `module->namespace` empty empty empty))])) diff --git a/compiler-lib/compiler/demodularizer/update-toplevels.rkt b/compiler-lib/compiler/demodularizer/update-toplevels.rkt index c1701d5412..c122511649 100644 --- a/compiler-lib/compiler/demodularizer/update-toplevels.rkt +++ b/compiler-lib/compiler/demodularizer/update-toplevels.rkt @@ -71,6 +71,11 @@ (update key) (update val) (update body))] + [(struct with-immed-mark (key val body)) + (make-with-immed-mark + (update key) + (update val) + (update body))] [(struct beg0 (seq)) (make-beg0 (map update seq))] [(struct varref (tl dummy)) From 490b10483a7c44bdf81bcac0848d3db5739b157d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 13 Aug 2015 20:03:52 -0600 Subject: [PATCH 433/466] compiler/zo-marshal: fix handling of cyclic scope data Insert CPT_SHARED as needed to break cycles within scope data. --- .../tests/compiler/zo-test-worker.rkt | 2 +- zo-lib/compiler/zo-marshal.rkt | 121 ++++++++++++------ zo-lib/compiler/zo-parse.rkt | 1 - 3 files changed, 85 insertions(+), 39 deletions(-) diff --git a/compiler-test/tests/compiler/zo-test-worker.rkt b/compiler-test/tests/compiler/zo-test-worker.rkt index 8be85d8121..416616f8e7 100644 --- a/compiler-test/tests/compiler/zo-test-worker.rkt +++ b/compiler-test/tests/compiler/zo-test-worker.rkt @@ -229,7 +229,7 @@ [marshal-parsed #t (zo-marshal parse-orig)] - [parse-marshalled + [parse-marshaled #t (zo-parse/bytes marshal-parsed)] #;[compare-parsed-to-parsed-marshalled diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 2a90ca01fd..cd3bb995ff 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -148,17 +148,18 @@ (define stx-objs (make-hasheq)) (define wraps (make-hasheq)) (define hash-consed (make-hash)) + (define hash-consed-results (make-hasheq)) ; (obj -> (or pos #f)) output-port -> number ; writes top to outp using shared-obj-pos to determine symref ; returns the file position at the end of the compilation top - (define (out-compilation-top shared-obj-pos shared-obj-unsee counting? outp) + (define (out-compilation-top shared-obj-pos shared-obj-pos-any counting? outp) (define ct (match top [(compilation-top max-let-depth prefix form) (list* max-let-depth prefix (protect-quote form))])) - (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee counting? - stx-objs wraps hash-consed)) + (out-anything ct (make-out outp shared-obj-pos shared-obj-pos-any counting? + stx-objs wraps hash-consed hash-consed-results)) (file-position outp)) ; -> vector @@ -172,16 +173,12 @@ (define (encounter! v) (hash-update! encountered v add1 0) #f) - (define (unencounter! v) - (define how-many-encounters (hash-ref encountered v)) - (when (= how-many-encounters 1) - (hash-set! encountered v 0))) (define (shared-obj-pos v #:error? [error? #f]) (hash-ref shared v (if error? (λ () (error 'symref "~e not in symbol table" v)) #f))) - (define (share! v) ; XXX this doesn't always set something, probably should be refactored + (define (share! v) (or (shared-obj-pos v) (let ([pos (add1 (hash-count shared))]) (hash-set! shared v pos) @@ -203,8 +200,7 @@ (share! v)] [else (encounter! v)])) - (λ (v) - (unencounter! v)) + (lambda (v) #f) #t (open-output-nowhere)) @@ -233,14 +229,14 @@ [i (in-naturals)]) (begin0 (file-position outp) - (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void #f - stx-objs wraps hash-consed)))) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) shared-obj-pos #f + stx-objs wraps hash-consed hash-consed-results)))) (file-position outp))) ; Calculate file positions (define counting-port (open-output-nowhere)) (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) - (define all-forms-length (out-compilation-top shared-obj-pos void #f counting-port)) + (define all-forms-length (out-compilation-top shared-obj-pos shared-obj-pos #f counting-port)) ; Write the compiled form header (write-bytes #"#~" outp) @@ -268,7 +264,7 @@ (write-bytes (int->bytes all-forms-length) outp) ; Actually write the zo (out-symbol-table symbol-table outp) - (out-compilation-top shared-obj-pos void #f outp) + (out-compilation-top shared-obj-pos shared-obj-pos #f outp) (void)) ;; ---------------------------------------- @@ -341,7 +337,7 @@ CPT_MODULE_VAR CPT_PATH CPT_CLOSURE - CPT_DELAY_REF ; XXX unused, but appears to be same as CPT_SYMREF + CPT_DELAY_REF ; XXX should be used to delay loading of syntax objects and lambda bodies CPT_PREFAB CPT_LET_ONE_UNUSED CPT_SCOPE @@ -393,22 +389,21 @@ (define-struct protected-symref (val)) -(define (encode-stx-obj w wraps-ht) +(define (encode-stx-obj w out) (match w [(struct stx-obj (datum wraps tamper-status)) (let* ([enc-datum (match datum [(cons a b) - (let ([p (cons (encode-stx-obj a wraps-ht) + (let ([p (cons (encode-stx-obj a out) (let bloop ([b b]) (match b ['() null] [(cons b1 b2) - (cons (encode-stx-obj b1 wraps-ht) + (cons (encode-stx-obj b1 out) (bloop b2))] [else - (encode-stx-obj b wraps-ht)])))] - ; XXX Cylic list error possible + (encode-stx-obj b out)])))] [len (let loop ([datum datum][len 0]) (cond [(null? datum) #f] @@ -420,32 +415,69 @@ (cons len p) p))] [(box x) - (box (encode-stx-obj x wraps-ht))] + (box (encode-stx-obj x out))] [(? vector? v) - (vector-map (lambda (e) (encode-stx-obj e wraps-ht)) v)] + (vector-map (lambda (e) (encode-stx-obj e out)) v)] [(? prefab-struct-key) (define l (vector->list (struct->vector datum))) (apply make-prefab-struct (car l) - (map (lambda (e) (encode-stx-obj e wraps-ht)) (cdr l)))] + (map (lambda (e) (encode-stx-obj e out)) (cdr l)))] [_ datum])] [p (cons enc-datum - (encode-wrap wraps wraps-ht))]) + (share-everywhere (encode-wrap wraps (out-wraps out)) out))]) (case tamper-status [(clean) p] [(tainted) (vector p)] [(armed) (vector p #f)]))])) -(define-struct out (s shared-index shared-unsee counting? stx-objs wraps hash-consed)) +(define-struct out (s + ;; The output port for writing bytecode. + shared-index + ;; Takes a value and reports/record sharing. + ;; On the first pass, the number of times this function is + ;; called for a value determines whether sharing is needed + ;; for the value. That sharing is reported on later passes + ;; by returning a number (a slot in "symbol" table) instead + ;; of #f. On the symbol-table filling pass, the first call + ;; produces #f so that a value is written into the table. + shared-index-any + ;; Like `shared-index`, but doesn't record any sharing or + ;; produce #f for the immediate value of a symbol table. + counting? + ;; Set to #t for the first (sharing-finding pass), #f + ;; otherwise. + stx-objs + ;; Hash table from syntax objects to encoded forms; set on + ;; first pass and encoding are retrieved on following passes. + wraps + ;; Hash table from syntax-object wraps to encodings; also + ;; set on first pass and used on later passes. + hash-consed + ;; Table of hash-consed parts of wrap encodings. This table + ;; is `equal?`-based, but with a wrapper to compare self + ;; modidxs with `eq?`. + hash-consed-results + ;; An `eq?`-based table of hash-cons results. Any of these + ;; values that are shared need to be written with CPT_SHARED + ;; so graph structure can be managed. + )) + (define (out-shared v out k) (if (shareable? v) - (let ([v ((out-shared-index out) v)]) - (if v + (let ([n ((out-shared-index out) v)]) + (if n (begin (out-byte CPT_SYMREF out) - (out-number v out)) - (k))) + (out-number n out)) + (let ([sharepoint? (hash-ref (out-hash-consed-results out) v #f)]) + (when sharepoint? + (let ([n2 ((out-shared-index-any out) v)]) + (when n2 + (out-byte CPT_SHARED out) + (out-number n2 out)))) + (k)))) (k))) (define (out-byte v out) @@ -534,7 +566,7 @@ [(? char?) (out-byte CPT_CHAR out) (out-number (char->integer v) out)] - [(? maybe-same-as-fixnum?) ;XXX not sure if it's okay to use fixnum? instead of exact range check + [(? maybe-same-as-fixnum?) (if (and (v . >= . 0) (v . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) (out-byte (+ CPT_SMALL_NUMBER_START v) out) @@ -880,6 +912,7 @@ (for ([n (in-range (sub1 len) -1 -1)]) (out-number (vector-ref vec n) out)))] [(? module-path-index?) + ;; XXX should add interning of module path indices (out-byte CPT_MODULE_INDEX out) (let-values ([(name base) (module-path-index-split v)]) (out-anything name out) @@ -898,7 +931,7 @@ (out-number relative-id out) (out-anything (share-everywhere content out) out)] [(? stx-obj?) - (out-anything (share-everywhere (lookup-encoded-stx-obj v out) out) out)] + (out-anything (lookup-encoded-stx-obj v out) out)] [(? prefab-struct-key) (define pre-v (struct->vector v)) (vector-set! pre-v 0 (prefab-struct-key v)) @@ -1052,7 +1085,7 @@ (define (lookup-encoded-stx-obj w out) (hash-ref! (out-stx-objs out) w (λ () - (encode-stx-obj w (out-wraps out))))) + (encode-stx-obj w out)))) (define (pack-binding-names binding-names) (define (ht-to-vector ht) @@ -1187,21 +1220,35 @@ [(box? a) (and (box? b) (simple-equal? (unbox a) (unbox b)))] + [(module-path-index? a) + (and (module-path-index? b) + (let-values ([(a-name a-base) (module-path-index-split a)] + [(b-name b-base) (module-path-index-split b)]) + (and a-name + a-base + (simple-equal? a-name b-name) + (simple-equal? a-base b-base))))] [else #f])) (define (share-everywhere v out) + (define (register r) + (hash-set! (out-hash-consed-results out) r #t) + r) (hash-ref! (out-hash-consed out) (modidx-must-be-eq v) (lambda () (cond [(pair? v) - (cons (share-everywhere (car v) out) - (share-everywhere (cdr v) out))] + (register + (cons (share-everywhere (car v) out) + (share-everywhere (cdr v) out)))] [(vector? v) - (for/vector #:length (vector-length v) ([e (in-vector v)]) - (share-everywhere e out))] + (register + (for/vector #:length (vector-length v) ([e (in-vector v)]) + (share-everywhere e out)))] [(box? v) - (box (share-everywhere (unbox v) out))] + (register + (box (share-everywhere (unbox v) out)))] [else v])))) ;; ---------------------------------------- diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 0d7b9ac55b..9e00c2461e 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -973,7 +973,6 @@ (vector-ref (cport-symtab cp) i)) (define (read-cyclic cp i who [wrap values]) - (define v (symtab-lookup cp i)) (define ph (make-placeholder (not-ready))) (symtab-write! cp i ph) (define r (wrap (read-compact cp))) From c3d1c9967f078edf142d98f33fabde5f69f798ff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 14 Aug 2015 07:25:35 -0600 Subject: [PATCH 434/466] extra output on failure for `tests/compiler/zo` --- compiler-test/tests/compiler/zo.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/compiler-test/tests/compiler/zo.rkt b/compiler-test/tests/compiler/zo.rkt index 67f2bfa486..c53f806773 100644 --- a/compiler-test/tests/compiler/zo.rkt +++ b/compiler-test/tests/compiler/zo.rkt @@ -76,7 +76,9 @@ (let ([o (open-output-bytes)]) (print p o) (get-output-string o)))]) - (unless (equal? (to-string p) (to-string p2)) - (error 'zo "failed on example: ~e" ex-mod)))))))) + (define s1 (to-string p)) + (define s2 (to-string p2)) + (unless (equal? s1 s2) + (error 'zo "failed on example: ~e\n~s\n~s" ex-mod s1 s2)))))))) (for-each check (list ex-mod1 ex-mod2 ex-mod3 ex-mod4 ex-mod5)) From b8055ffaa5dbea599b89a0cbacd64d37a58413dc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 14 Aug 2015 11:59:18 -0400 Subject: [PATCH 435/466] Increase timeout for demod-test. --- compiler-test/tests/compiler/demodularizer/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler-test/tests/compiler/demodularizer/info.rkt b/compiler-test/tests/compiler/demodularizer/info.rkt index 2e2cc3258d..355d8e262d 100644 --- a/compiler-test/tests/compiler/demodularizer/info.rkt +++ b/compiler-test/tests/compiler/demodularizer/info.rkt @@ -1,3 +1,3 @@ #lang info -(define test-timeouts '(("demod-test.rkt" 120))) +(define test-timeouts '(("demod-test.rkt" 300))) From 1d9e2003ac64b00c01e6d3e355dc7e2d1d1a5285 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 19 Aug 2015 14:15:55 -0500 Subject: [PATCH 436/466] Remove dependency on `unstable/struct`. --- compiler-lib/compiler/demodularizer/replace-modidx.rkt | 2 +- zo-lib/compiler/zo-marshal.rkt | 1 - zo-lib/compiler/zo-parse.rkt | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/compiler-lib/compiler/demodularizer/replace-modidx.rkt b/compiler-lib/compiler/demodularizer/replace-modidx.rkt index f470e2b8f1..4cd6fc698a 100644 --- a/compiler-lib/compiler/demodularizer/replace-modidx.rkt +++ b/compiler-lib/compiler/demodularizer/replace-modidx.rkt @@ -2,7 +2,7 @@ (require racket/match racket/vector - unstable/struct + racket/struct "util.rkt") (provide replace-modidx) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index cd3bb995ff..960c7cbe30 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -1,6 +1,5 @@ #lang racket/base (require compiler/zo-structs - unstable/struct racket/port racket/vector racket/match diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 9e00c2461e..a6a64aa2b6 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -2,7 +2,7 @@ (require racket/function racket/match racket/list - unstable/struct + racket/struct compiler/zo-structs racket/dict racket/set) From 5ef6a2662d51831061e007ef2187d416bb34ffab Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 16 Aug 2015 16:09:11 -0400 Subject: [PATCH 437/466] Missing `in-list` calls. --- compiler-lib/compiler/commands/test.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index 1458f23499..b0d2f81661 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -643,7 +643,7 @@ (links #:file file #:user? user? #:version-regexp version-re #:root? #t))] #:when (directory-exists? cp) - [collection (directory-list cp)] + [collection (in-list (directory-list cp))] #:when (directory-exists? (build-path cp collection))) (col (path->string collection) (build-path cp collection))))) @@ -655,7 +655,7 @@ (append* (for/list ([cp (current-library-collection-paths)] #:when (directory-exists? cp) - [collection (directory-list cp)] + [collection (in-list (directory-list cp))] #:when (directory-exists? (build-path cp collection))) (col (path->string collection) (build-path cp collection))) From adbeebabafef096dcd64df5946a219c67bebb6b8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 22 Aug 2015 09:48:05 -0600 Subject: [PATCH 438/466] raco test: recognize extensible set of module suffixes Use the new `compiler/module-suffix` library. --- compiler-lib/compiler/commands/test.rkt | 7 ++++--- compiler-lib/info.rkt | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index b0d2f81661..e310a16ed9 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -16,9 +16,10 @@ pkg/lib pkg/path setup/collects - setup/getinfo) + setup/getinfo + compiler/module-suffix) -(define rx:default-suffixes #rx#"\\.(?:rkt|scrbl)$") +(define rx:default-suffixes (get-module-suffix-regexp)) ;; For any other file suffix, a `test-command-line-arguments` ;; entry is required in "info.rkt". @@ -557,7 +558,7 @@ (directory-list p) #:sema continue-sema)))] [(and (or (not check-suffix?) - (regexp-match rx:default-suffixes p) + (regexp-match? rx:default-suffixes p) (get-cmdline p #f #:check-info? #t) (include-path? p #:check-info? #t)) (or (not check-suffix?) diff --git a/compiler-lib/info.rkt b/compiler-lib/info.rkt index f83bb4e6cb..4cbd2611a5 100644 --- a/compiler-lib/info.rkt +++ b/compiler-lib/info.rkt @@ -2,7 +2,7 @@ (define collection 'multi) -(define deps '(["base" #:version "6.1.1.8"] +(define deps '(["base" #:version "6.2.900.10"] "scheme-lib" "rackunit-lib" "zo-lib")) @@ -13,4 +13,4 @@ (define pkg-authors '(mflatt)) -(define version "1.3") +(define version "1.4") From c1d05fa694a99d736b1a1dfd2bb522545b766773 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 2 Sep 2015 12:50:09 -0600 Subject: [PATCH 439/466] update bytecode tools for syntax-object source locations --- compiler-lib/compiler/decompile.rkt | 11 ++- compiler-lib/compiler/demodularizer/nodep.rkt | 4 +- zo-lib/compiler/zo-marshal.rkt | 80 ++++++++++++++++--- zo-lib/compiler/zo-parse.rkt | 63 ++++++++++++--- zo-lib/compiler/zo-structs.rkt | 4 +- 5 files changed, 134 insertions(+), 28 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 3d25c16e2b..73748b7d8b 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -200,7 +200,7 @@ (let ([p (mcons #f #f)]) (hash-set! stx-ht stx p) (match stx - [(stx-obj datum wrap tamper-status) + [(stx-obj datum wrap srcloc props tamper-status) (set-mcar! p (case tamper-status [(clean) 'wrap] [(tainted) 'wrap-tainted] @@ -223,7 +223,14 @@ [(box? datum) (box (decompile-stx (unbox datum) stx-ht))] [else datum]) - wrap)) + (let* ([l (mcons wrap null)] + [l (if (hash-count props) + (mcons props l) + l)] + [l (if srcloc + (mcons srcloc l) + l)]) + l))) p])))) (define (mpi->string modidx) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index d3741f5977..6bbaa66bae 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -197,13 +197,13 @@ empty (begin (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))] + (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))] [(module-path-index? ct) (if (hash-has-key? REQUIRED ct) empty (begin (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))] + (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))] [(not ct) empty] [(@phase? ct) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 960c7cbe30..2ed9e5ce93 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -390,10 +390,10 @@ (define (encode-stx-obj w out) (match w - [(struct stx-obj (datum wraps tamper-status)) + [(struct stx-obj (datum wraps srcloc props tamper-status)) (let* ([enc-datum (match datum - [(cons a b) + [(cons a b) (let ([p (cons (encode-stx-obj a out) (let bloop ([b b]) (match b @@ -424,12 +424,39 @@ (car l) (map (lambda (e) (encode-stx-obj e out)) (cdr l)))] [_ datum])] - [p (cons enc-datum - (share-everywhere (encode-wrap wraps (out-wraps out)) out))]) - (case tamper-status - [(clean) p] - [(tainted) (vector p)] - [(armed) (vector p #f)]))])) + [e-wraps (share-everywhere (encode-wrap wraps (out-wraps out)) out)] + [esrcloc (let () + (define (avail? n) (n . >= . 0)) + (define (xvector a b c d e) + (case (hash-ref props 'paren-shape #f) + [(#\[) (vector a b c d e #\[)] + [(#\{) (vector a b c d e #\{)] + [else (if (or a (avail? b) (avail? c) (avail? d)) + (vector a b c d e) + #f)])) + (define (norm v) (or v -1)) + (share-everywhere + (if srcloc + (xvector (srcloc-source srcloc) + (norm (srcloc-line srcloc)) + (norm (srcloc-column srcloc)) + (norm (srcloc-position srcloc)) + (norm (srcloc-span srcloc))) + (xvector #f -1 -1 -1 -1)) + out))]) + (cond + [esrcloc + (case tamper-status + [(tainted) (vector enc-datum e-wraps esrcloc 1)] + [(armed) (vector enc-datum e-wraps esrcloc 2)] + [else (vector enc-datum e-wraps esrcloc)])] + [(not (eq? tamper-status 'clean)) + (vector enc-datum e-wraps + (case tamper-status + [(tainted) 1] + [(armed) 2]))] + [else + (cons enc-datum e-wraps)]))])) (define-struct out (s ;; The output port for writing bytecode. @@ -940,8 +967,41 @@ (out-byte CPT_QUOTE out) (parameterize ([quoting? #t]) (out-anything qv out))] - [(or (? path?) ; XXX Why not use CPT_PATH? - (? regexp?) + [(? path?) + (out-byte CPT_PATH out) + (define (within? p) + (and (relative-path? p) + (let loop ([p p]) + (define-values (base name dir?) (split-path p)) + (and (not (eq? name 'up)) + (not (eq? name 'same)) + (or (not (path? base)) + (loop base)))))) + (define maybe-rel + (and (current-write-relative-directory) + (let ([dir (current-write-relative-directory)]) + (and (or (not dir) + (within? (find-relative-path v + (if (pair? dir) + (cdr dir) + dir)))) + (find-relative-path v + (if (pair? dir) + (car dir) + dir)))))) + (cond + [(not maybe-rel) + (define bstr (path->bytes v)) + (out-number (bytes-length bstr) out) + (out-bytes bstr out)] + [else + (out-number 0 out) + (out-anything (for/list ([e (in-list (explode-path maybe-rel))]) + (if (path? e) + (path-element->bytes e) + e)) + out)])] + [(or (? regexp?) (? byte-regexp?) (? number?) (? extflonum?)) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index a6a64aa2b6..2389c36c9c 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -600,14 +600,17 @@ (define (decode-wrapped cp v) (let loop ([v v]) - (let-values ([(tamper-status v encoded-wraps) + (let-values ([(tamper-status v encoded-wraps esrcloc) (match v - [`#((,datum . ,wraps)) (values 'tainted datum wraps)] - [`#((,datum . ,wraps) #f) (values 'armed datum wraps)] - [`(,datum . ,wraps) (values 'clean datum wraps)] + [`#(,datum ,wraps 1) (values 'tainted datum wraps #f)] + [`#(,datum ,wraps 2) (values 'armed datum wraps #f)] + [`#(,datum ,wraps ,esrcloc 1) (values 'tainted datum wraps esrcloc)] + [`#(,datum ,wraps ,esrcloc 2) (values 'armed datum wraps esrcloc)] + [`#(,datum ,wraps ,esrcloc) (values 'clean datum wraps esrcloc)] + [`(,datum . ,wraps) (values 'clean datum wraps #f)] [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) (let* ([wrapped-memo (make-memo)] - [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps tamper-status)))]) + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps esrcloc #hasheq() tamper-status)))]) (cond [(pair? v) (if (eq? #t (car v)) @@ -800,11 +803,15 @@ [flags (if (< p* 0) (read-compact-number cp) 0)]) (make-local #t p flags))] [(path) - (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))]) - (if (relative-path? p) - (path->complete-path p (or (current-load-relative-directory) - (current-directory))) - p))] + (let ([len (read-compact-number cp)]) + (if (zero? len) + ;; Read a list of byte strings as relative path elements: + (let ([p (or (current-load-relative-directory) + (current-directory))]) + (for/fold ([p p]) ([e (in-list (read-compact cp))]) + (build-path p (if (bytes? e) (bytes->path-element e) e)))) + ;; Read a path: + (bytes->path (read-compact-bytes cp len))))] [(small-number) (let ([l (- ch cpt-start)]) l)] @@ -1145,6 +1152,7 @@ ;; We do this after building a graph from the input, and `decode-wrap` ;; preserves graph structure. (define decode-ht (make-hasheq)) + (define srcloc-ht (make-hasheq)) (let walk ([p v]) (match p [(compilation-top _ pfx c) @@ -1182,10 +1190,13 @@ [(seq-for-syntax _ pfx _ _) (struct-copy seq-for-syntax p [prefix (walk pfx)])] - [(stx-obj d w _) + [(stx-obj d w esrcloc _ _) + (define-values (srcloc props) (decode-srcloc+props esrcloc srcloc-ht)) (struct-copy stx-obj p [datum (walk d)] - [wrap (decode-wrap w decode-ht)])] + [wrap (decode-wrap w decode-ht)] + [srcloc srcloc] + [props props])] [(? zo?) p] ;; Generic constructors happen inside the `datum` of `stx-obj`, ;; for example (with no cycles): @@ -1217,6 +1228,32 @@ ;; ---------------------------------------- +(define (decode-srcloc+props esrcloc ht) + (define (norm v) (if (v . < . 0) #f v)) + (define p + (hash-ref! ht + esrcloc + (lambda () + (cons (and esrcloc + ;; We could reduce this srcloc to #f if + ;; there's no source, line, column, or position + ;; information, but we want to expose the actual + ;; content of a bytecode stream: + (srcloc (vector-ref esrcloc 0) + (norm (vector-ref esrcloc 1)) + (norm (vector-ref esrcloc 2)) + (norm (vector-ref esrcloc 3)) + (norm (vector-ref esrcloc 4)))) + (if (and esrcloc ((vector-length esrcloc) . > . 5)) + (case (vector-ref esrcloc 5) + [(#\[) #hasheq((paren-shape . #\[))] + [(#\{) #hasheq((paren-shape . #\{))] + [else #hasheq()]) + #hasheq()))))) + (values (car p) (cdr p))) + +;; ---------------------------------------- + (define (decode-wrap encoded-wrap ht) (hash-ref! ht encoded-wrap @@ -1307,7 +1344,7 @@ [(box (cons base-b (cons (cons sym wraps) phase))) (free-id=?-binding (decode-binding base-b ht) - (stx-obj sym (decode-wrap wraps ht) 'clean) + (stx-obj sym (decode-wrap wraps ht) #f #hasheq() 'clean) phase)] [(? symbol?) (local-binding b)] diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index 5b83c6047a..c7db5e3a08 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -184,7 +184,9 @@ (define-form-struct stx ([content stx-obj?])) (define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components - [wrap any/c] ; shuold be `wrap?`, but encoded form appears initially + [wrap any/c] ; should be `wrap?`, but encoded form appears initially + [srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially + [props (hash/c symbol? any/c)] [tamper-status (or/c 'clean 'armed 'tainted)])) (define-form-struct wrap ([shifts (listof module-shift?)] From 2a542b3966a6b1de04c76c36dcf27442f58c6ca3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 2 Sep 2015 18:20:53 -0600 Subject: [PATCH 440/466] restore accidentally disabled tests --- compiler-test/tests/compiler/embed/test.rkt | 2 -- 1 file changed, 2 deletions(-) diff --git a/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt index ef67538317..1bbcacd1f9 100644 --- a/compiler-test/tests/compiler/embed/test.rkt +++ b/compiler-test/tests/compiler/embed/test.rkt @@ -656,7 +656,6 @@ ;; ---------------------------------------- -#| REMOVEME (try-basic) (try-mzc) (try-extension) @@ -664,7 +663,6 @@ (try-reader) (try-planet) (try-*sl) -|# (try-source) ;; ---------------------------------------- From 89d99b92da65e916c7b997b27fed81706bf10de5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 Sep 2015 13:13:38 -0600 Subject: [PATCH 441/466] update for 6.2.900.15 bytecode change The `compilation-top` bytecode form has a new `binding-namess` field. --- compiler-lib/compiler/decompile.rkt | 4 ++-- compiler-lib/compiler/demodularizer/alpha.rkt | 4 ++-- .../compiler/demodularizer/gc-toplevels.rkt | 3 ++- compiler-lib/compiler/demodularizer/merge.rkt | 4 ++-- compiler-lib/compiler/demodularizer/module.rkt | 3 ++- compiler-lib/compiler/demodularizer/nodep.rkt | 4 ++-- zo-lib/compiler/zo-marshal.rkt | 14 ++++++++++++-- zo-lib/compiler/zo-parse.rkt | 18 +++++++++++++++--- zo-lib/compiler/zo-structs.rkt | 6 +++++- 9 files changed, 44 insertions(+), 16 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 73748b7d8b..fc5ce2ad82 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -33,7 +33,7 @@ (with-output-to-bytes (λ () (write (cdr b)))))))]) (let ([n (match v - [(struct compilation-top (_ prefix (struct primval (n)))) n] + [(struct compilation-top (_ _ prefix (struct primval (n)))) n] [else #f])]) (hash-set! table n (car b))))) table)) @@ -53,7 +53,7 @@ (define (decompile top) (let ([stx-ht (make-hasheq)]) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) (expose-module-path-indexes `(begin diff --git a/compiler-lib/compiler/demodularizer/alpha.rkt b/compiler-lib/compiler/demodularizer/alpha.rkt index 2f3c71398d..63dc5508a8 100644 --- a/compiler-lib/compiler/demodularizer/alpha.rkt +++ b/compiler-lib/compiler/demodularizer/alpha.rkt @@ -4,8 +4,8 @@ (define (alpha-vary-ctop top) (match top - [(struct compilation-top (max-let-depth prefix form)) - (make-compilation-top max-let-depth (alpha-vary-prefix prefix) form)])) + [(struct compilation-top (max-let-depth binding-namess prefix form)) + (make-compilation-top max-let-depth binding-namess (alpha-vary-prefix prefix) form)])) (define (alpha-vary-prefix p) (struct-copy prefix p [toplevels diff --git a/compiler-lib/compiler/demodularizer/gc-toplevels.rkt b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt index ccdebc57ff..6f4987bd2d 100644 --- a/compiler-lib/compiler/demodularizer/gc-toplevels.rkt +++ b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt @@ -10,7 +10,7 @@ ; XXX Use efficient set structure (define (gc-toplevels top) (match top - [(struct compilation-top (max-let-depth top-prefix form)) + [(struct compilation-top (max-let-depth binding-namess top-prefix form)) (define lift-start (prefix-lift-start top-prefix)) (define max-depgraph-index @@ -54,6 +54,7 @@ (log-debug (format "Used stxs: ~S" ordered-stxs)) (make-compilation-top max-let-depth + #hash() new-prefix new-form)])) diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt index 3aeeadd18e..fd7ddff67f 100644 --- a/compiler-lib/compiler/demodularizer/merge.rkt +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -15,7 +15,7 @@ (define (merge-compilation-top get-modvar-rewrite top) (parameterize ([current-get-modvar-rewrite get-modvar-rewrite]) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (define-values (new-max-let-depth new-prefix gen-new-forms) (merge-form max-let-depth prefix form)) (define total-tls (length (prefix-toplevels new-prefix))) @@ -29,7 +29,7 @@ [p (in-list (prefix-toplevels new-prefix))]) (log-debug (format "new-prefix tls\t~v ~v" i p))) (make-compilation-top - new-max-let-depth new-prefix + new-max-let-depth #hash() new-prefix (make-splice (gen-new-forms new-prefix)))] [else (error 'merge "unrecognized: ~e" top)]))) diff --git a/compiler-lib/compiler/demodularizer/module.rkt b/compiler-lib/compiler/demodularizer/module.rkt index 6c7a3bc9c6..4f984c27af 100644 --- a/compiler-lib/compiler/demodularizer/module.rkt +++ b/compiler-lib/compiler/demodularizer/module.rkt @@ -13,13 +13,14 @@ (define (wrap-in-kernel-module name srcname lang-info self-modidx top) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (define-values (reqs new-forms) (partition req? (splice-forms form))) (define requires (map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs)) (make-compilation-top 0 + #hash() (make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix)) (make-mod name srcname self-modidx diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index 6bbaa66bae..7d7bada6f1 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -107,9 +107,9 @@ (define (nodep top phase) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase)) - (values modvar-rewrite lang-info (make-compilation-top max-let-depth prefix new-form))] + (values modvar-rewrite lang-info (make-compilation-top max-let-depth #hash() prefix new-form))] [else (error 'nodep "unrecognized: ~e" top)])) (define (nodep-form form phase) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 2ed9e5ce93..0684e7261c 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -155,8 +155,11 @@ (define (out-compilation-top shared-obj-pos shared-obj-pos-any counting? outp) (define ct (match top - [(compilation-top max-let-depth prefix form) - (list* max-let-depth prefix (protect-quote form))])) + [(compilation-top max-let-depth binding-namess prefix form) + (list* max-let-depth + (binding-namess-hash->list binding-namess) + prefix + (protect-quote form))])) (out-anything ct (make-out outp shared-obj-pos shared-obj-pos-any counting? stx-objs wraps hash-consed hash-consed-results)) (file-position outp)) @@ -1247,6 +1250,13 @@ (find-relative-path r v) v))) +(define (binding-namess-hash->list binding-namess) + (for/list ([(phase t) (in-hash binding-namess)]) + (cons phase + (list->vector + (apply append (for/list ([(id sym) (in-hash t)]) + (list id sym))))))) + ;; ---------------------------------------- ;; We want to hash-cons syntax-object wraps, but a normal `equal?`-based diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 2389c36c9c..04010dbaf3 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -43,10 +43,21 @@ (define (read-compilation-top v) (match v - [`(,ld ,prefix . ,code) + [`(,ld ,binding-namess ,prefix . ,code) (unless (prefix? prefix) (error 'bad "not prefix ~a" prefix)) - (make-compilation-top ld prefix code)])) + (make-compilation-top ld + (binding-namess-list->hash binding-namess) + prefix + code)])) + +(define (binding-namess-list->hash binding-namess) + (for/hash ([e (in-list binding-namess)]) + (values (car e) + (let ([vec (cdr e)]) + (for/hash ([i (in-range 0 (vector-length vec) 2)]) + (values (vector-ref vec i) + (vector-ref vec (add1 i)))))))) (define (read-resolve-prefix v) (match v @@ -1155,8 +1166,9 @@ (define srcloc-ht (make-hasheq)) (let walk ([p v]) (match p - [(compilation-top _ pfx c) + [(compilation-top _ binding-namess pfx c) (struct-copy compilation-top p + [binding-namess (walk binding-namess)] [prefix (walk pfx)] [code (walk c)])] [(prefix _ _ s _) diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index c7db5e3a08..fecdece92b 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -66,7 +66,11 @@ (define-form-struct form ()) (define-form-struct (expr form) ()) -(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? any/c)])) ; compiled code always wrapped with this +(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] + [binding-namess (hash/c exact-nonnegative-integer? + (hash/c symbol? identifier?))] + [prefix prefix?] + [code (or/c form? any/c)])) ; compiled code always wrapped with this ;; A provided identifier (define-form-struct provided ([name symbol?] From 6632070f75fcf99a7c244623ddbe1db9bd440394 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 Sep 2015 17:39:31 -0600 Subject: [PATCH 442/466] repair test for new `compilation-top` field --- compiler-test/tests/compiler/zo-exs.rkt | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/compiler-test/tests/compiler/zo-exs.rkt b/compiler-test/tests/compiler/zo-exs.rkt index 03c836bbd0..90a025c951 100644 --- a/compiler-test/tests/compiler/zo-exs.rkt +++ b/compiler-test/tests/compiler/zo-exs.rkt @@ -27,21 +27,25 @@ (test (roundtrip - (compilation-top 0 + (compilation-top 0 + #hash() (prefix 0 empty empty 'insp0) (list 1 (list 2 3) (list 2 3) 4 5))) (roundtrip - (compilation-top 0 + (compilation-top 0 + #hash() (prefix 1 empty empty 'insp0) (list (lam 'proc null 0 null #f #(0) '(val/ref) (set 0) 3 1)))) (roundtrip - (compilation-top 0 + (compilation-top 0 + #hash() (prefix 1 empty empty 'insp0) (list (lam 'proc null 0 null #f #(0) '(val/ref) #f 3 1)))) #;(roundtrip (compilation-top 0 + #hash() (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] [x (closure @@ -62,6 +66,7 @@ #;(roundtrip (compilation-top 0 + #hash() (prefix 0 (list #f) (list)) (mod 'simple @@ -93,18 +98,21 @@ #t))) (roundtrip - (compilation-top 0 + (compilation-top 0 + #hash() (prefix 0 empty empty 'insp0) (current-directory))) (roundtrip - (compilation-top 0 + (compilation-top 0 + #hash() (prefix 0 empty empty 'insp0) (list (current-directory)))) (roundtrip (compilation-top 0 + #hash() (prefix 0 empty empty 'insp0) (cons #hash() #hash()))) @@ -112,5 +120,6 @@ (roundtrip (compilation-top 0 + #hash() (prefix 0 empty empty 'insp0) #hash()))) From 9571b33f406185be5d33a383098c93f16b7db801 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 6 Sep 2015 16:07:35 -0600 Subject: [PATCH 443/466] zo-marshal: add missing `protect-quote` The `protect-quote` call is needed when the right-hand side of a `set!` is a literal hash table, for example. --- zo-lib/compiler/zo-marshal.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 0684e7261c..d6eb6fbf82 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -728,7 +728,7 @@ (out-number id out)] [(struct assign (id rhs undef-ok?)) (out-marshaled set-bang-type-num - (cons undef-ok? (cons id rhs)) + (cons undef-ok? (cons id (protect-quote rhs))) out)] [(struct localref (unbox? offset clear? other-clears? type)) (if (and (not clear?) (not other-clears?) (not flonum?) From 7d60d6d8850ba3dc3e3219ebc3e67c73d781fdfc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 7 Sep 2015 08:26:40 -0600 Subject: [PATCH 444/466] fix contract on `compilation-top` field A binding-name table has identifiers encoded as `stx`, not actual identifiers. --- zo-lib/compiler/zo-structs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index fecdece92b..a38134be23 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -68,7 +68,7 @@ (define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [binding-namess (hash/c exact-nonnegative-integer? - (hash/c symbol? identifier?))] + (hash/c symbol? stx?))] [prefix prefix?] [code (or/c form? any/c)])) ; compiled code always wrapped with this From 796b0796f442d4e22256dc4a8c66142caa9ff942 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 7 Sep 2015 11:59:15 -0600 Subject: [PATCH 445/466] raco test: run `configure-runtime` submodule of module to test Unless `-s` or `--submodule` is specified, and as long as each test is run in its own place or process, require a `configure-runtime` submodule of the specified module before running the module or its `test` submodule. For example, this change makes `raco test` run `htdp/bsl` tests with printing configured correctly for `htdp/bsl`. --- compiler-lib/compiler/commands/test.rkt | 54 +++++++++++++------ compiler-test/tests/compiler/test/racket.rkt | 2 + compiler-test/tests/compiler/test/runtime.rkt | 29 ++++++++++ compiler-test/tests/compiler/test/scheme.rkt | 2 + 4 files changed, 70 insertions(+), 17 deletions(-) create mode 100644 compiler-test/tests/compiler/test/racket.rkt create mode 100644 compiler-test/tests/compiler/test/runtime.rkt create mode 100644 compiler-test/tests/compiler/test/scheme.rkt diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index e310a16ed9..5c71cce195 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -24,6 +24,7 @@ ;; entry is required in "info.rkt". (define submodules '()) ; '() means "default" +(define configure-runtime 'default) (define first-avail? #f) (define run-anyways? #t) (define quiet? #f) @@ -61,8 +62,9 @@ (define argv (current-command-line-arguments)) (define result-file (vector-ref argv 0)) (define test-module (read (open-input-string (vector-ref argv 1)))) - (define d (read (open-input-string (vector-ref argv 2)))) - (define args (list-tail (vector->list argv) 3)) + (define rt-module (read (open-input-string (vector-ref argv 2)))) + (define d (read (open-input-string (vector-ref argv 3)))) + (define args (list-tail (vector->list argv) 4)) ;; In case PLTUSERHOME is set, make sure relevant ;; directories exist: @@ -71,6 +73,7 @@ (ready-dir (find-system-path 'doc-dir)) (parameterize ([current-command-line-arguments (list->vector args)]) + (when rt-module (dynamic-require rt-module d)) (dynamic-require test-module d) ((executable-yield-handler) 0)) @@ -90,9 +93,10 @@ (define l (place-channel-get pch)) ;; Run the test: (parameterize ([current-command-line-arguments (list->vector - (cadddr l))] - [current-directory (caddr l)]) - (dynamic-require (car l) (cadr l)) + (cadddr (cdr l)))] + [current-directory (cadddr l)]) + (when (cadr l) (dynamic-require (cadr l) (caddr l))) + (dynamic-require (car l) (caddr l)) ((executable-yield-handler) 0)) ;; If the tests use `rackunit`, collect result stats: (define test-results @@ -110,7 +114,7 @@ ;; Run each test in its own place or process, and collect both test ;; results and whether any output went to stderr. -(define (dynamic-require-elsewhere p d args +(define (dynamic-require-elsewhere p rt-p d args #:id id #:mode [mode (or default-mode (if single-file? @@ -155,7 +159,8 @@ (when lock-name (fprintf stdout "raco test:~a @(lock-name ~s)\n" id - lock-name))) + lock-name)) + (flush-output stdout)) (define-values (result-code test-results) (case mode @@ -169,6 +174,7 @@ [current-command-line-arguments (list->vector args)]) (thread (lambda () + (when rt-p (dynamic-require rt-p d)) (dynamic-require p d) ((executable-yield-handler) 0) (set! done? #t))))) @@ -192,7 +198,7 @@ #:err stderr))) ;; Send the module path to test: - (place-channel-put pl (list p d (current-directory) args)) + (place-channel-put pl (list p rt-p d (current-directory) args)) ;; Wait for the place to finish: (unless (sync/timeout timeout (place-dead-evt pl)) @@ -234,6 +240,7 @@ "(dynamic-require '(submod compiler/commands/test process) #f)" tmp-file (format "~s" (normalize-module-path p)) + (format "~s" (normalize-module-path rt-p)) (format "~s" d) args))) (define proc (list-ref ps 4)) @@ -319,7 +326,7 @@ (append mod '(config)) (error test-exe-name "cannot add test-config submodule to path: ~s" mod))) -(define (dynamic-require* p d +(define (dynamic-require* p rt-p d #:id id #:try-config? try-config? #:args args @@ -335,7 +342,7 @@ [else #f]) (lambda (what get-default) (get-default)))) (dynamic-require-elsewhere - p d args + p rt-p d args #:id id #:responsible (lookup 'responsible (lambda () responsible)) @@ -461,7 +468,7 @@ ;; Perform test of one module (in parallel, as allowed by ;; `task-sema`): -(define (test-module p mod +(define (test-module p mod rt-mod #:sema continue-sema #:try-config? try-config? #:args [args '()] @@ -513,7 +520,7 @@ m))))) (loop))))))) (begin0 - (dynamic-require* mod 0 + (dynamic-require* mod rt-mod 0 #:id (if (jobs . <= . 1) "" (format " ~a" id)) @@ -577,8 +584,8 @@ base (current-directory)))]) (define file-name (file-name-from-path p)) - (define (test-this-module mod try-config?) - (test-module p mod + (define (test-this-module mod rt-mod try-config?) + (test-module p mod rt-mod #:try-config? try-config? #:sema continue-sema #:args args @@ -589,7 +596,12 @@ (with-summary `(file ,p) (let ([something-wasnt-declared? #f] - [did-one? #f]) + [did-one? #f] + [rt-mod + (and configure-runtime + (let ([mod `(submod ,file-name configure-runtime)]) + (and (module-declared? mod #t) + mod)))]) (filter values (append @@ -612,13 +624,13 @@ 'ok)) => (lambda (mode) (set! did-one? #t) - (test-this-module mod (eq? mode 'ok)))] + (test-this-module mod rt-mod (eq? mode 'ok)))] [else (set! something-wasnt-declared? #t) #f])) (list (and (and run-anyways? something-wasnt-declared?) - (test-this-module file-name #f))))))))] + (test-this-module file-name rt-mod #f))))))))] [else (summary 0 0 #f null 0)])])) (module paths racket/base @@ -974,6 +986,9 @@ [("--first-avail") "Run only the first available submodule" (set! first-avail? #f)] + [("--configure-runtime") + "Run the `configure-runtime' submodule" + (set! configure-runtime #t)] #:once-any [("--direct") "Run tests directly (default for a single file)" @@ -1021,6 +1036,11 @@ #:args file-or-directory (begin (unless (= 1 (length file-or-directory)) (set! single-file? #f)) + (when (and (eq? configure-runtime 'default) + (or (and (not single-file?) + (not (memq default-mode '(process place)))) + (not (null? submodules)))) + (set! configure-runtime #f)) (define sum ;; The #:sema argument everywhre makes tests start ;; in a deterministic order: diff --git a/compiler-test/tests/compiler/test/racket.rkt b/compiler-test/tests/compiler/test/racket.rkt new file mode 100644 index 0000000000..e0938ceaf3 --- /dev/null +++ b/compiler-test/tests/compiler/test/racket.rkt @@ -0,0 +1,2 @@ +#lang racket/base +(list 1 2) diff --git a/compiler-test/tests/compiler/test/runtime.rkt b/compiler-test/tests/compiler/test/runtime.rkt new file mode 100644 index 0000000000..5ecc70bb90 --- /dev/null +++ b/compiler-test/tests/compiler/test/runtime.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require racket/system + compiler/find-exe) + +(define exe (find-exe)) + +(define (try mode mod expect) + (printf "trying ~s ~s\n" mod mode) + (define s (open-output-bytes)) + (parameterize ([current-output-port s]) + (system* exe "-l-" "raco" "test" + mode "-l" (string-append "tests/compiler/test/" mod))) + (define last-line + (for/fold ([prev #f]) ([s (in-lines (open-input-bytes (get-output-bytes s)))]) + (if (or (eof-object? s) + (equal? s "1 test passed")) + prev + s))) + (unless (equal? expect last-line) + (error 'runtime "test failed\n module: ~s\n expected: ~s\n got: ~s" + mod expect last-line))) + +(for ([mod '("--direct" "--place" "--process")]) + (try mod "racket.rkt" "'(1 2)") + (try mod "scheme.rkt" "(1 2)")) + + + + diff --git a/compiler-test/tests/compiler/test/scheme.rkt b/compiler-test/tests/compiler/test/scheme.rkt new file mode 100644 index 0000000000..d2245f7c50 --- /dev/null +++ b/compiler-test/tests/compiler/test/scheme.rkt @@ -0,0 +1,2 @@ +#lang scheme/base +(list 1 2) From ae3c87c10617b98019395993c41191014f3f416d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 7 Sep 2015 12:02:02 -0600 Subject: [PATCH 446/466] fix "extensions" test to work when files are compiled --- compiler-test/tests/compiler/test/extensions/info.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler-test/tests/compiler/test/extensions/info.rkt b/compiler-test/tests/compiler/test/extensions/info.rkt index 572ef689aa..c7f196c63d 100644 --- a/compiler-test/tests/compiler/test/extensions/info.rkt +++ b/compiler-test/tests/compiler/test/extensions/info.rkt @@ -1,3 +1,3 @@ #lang info -(define test-omit-paths '(#rx".*omit.*")) -(define test-include-paths '(#rx".*include.*")) +(define test-omit-paths '(#rx".*omit.*[.](rkt|racket-file)$")) +(define test-include-paths '(#rx".*include.*[.](rkt|racket-file)$")) From 02de19eb6f6243f47d0d651570de3fd95c4fa7b4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 17 Sep 2015 15:02:16 -0400 Subject: [PATCH 447/466] who? me? --- compiler-test/tests/compiler/embed/info.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/compiler-test/tests/compiler/embed/info.rkt b/compiler-test/tests/compiler/embed/info.rkt index c498742dd3..5f50add10e 100644 --- a/compiler-test/tests/compiler/embed/info.rkt +++ b/compiler-test/tests/compiler/embed/info.rkt @@ -18,3 +18,5 @@ "embed-planet-2")) (define test-timeouts '(("test.rkt" 600))) + +(define test-responsibles '((all mflatt))) From 091db74ab6d1ed8bd9d317c8d84249f156933edf Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 30 Nov 2015 08:29:54 -0500 Subject: [PATCH 448/466] Don't include directory when using default suffixes --- compiler-lib/compiler/commands/test.rkt | 2 +- compiler-test/tests/compiler/test/d/.ignored.rkt | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 compiler-test/tests/compiler/test/d/.ignored.rkt diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index 5c71cce195..c306eda2f7 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -565,7 +565,7 @@ (directory-list p) #:sema continue-sema)))] [(and (or (not check-suffix?) - (regexp-match? rx:default-suffixes p) + (regexp-match? rx:default-suffixes (file-name-from-path p)) (get-cmdline p #f #:check-info? #t) (include-path? p #:check-info? #t)) (or (not check-suffix?) diff --git a/compiler-test/tests/compiler/test/d/.ignored.rkt b/compiler-test/tests/compiler/test/d/.ignored.rkt new file mode 100644 index 0000000000..1cc00a2f23 --- /dev/null +++ b/compiler-test/tests/compiler/test/d/.ignored.rkt @@ -0,0 +1,2 @@ +#lang racket/base +(error 'ignored "I shouldn't run!") From cfc28ee82a45496aa64443b8fa5159682987a55b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 1 Dec 2015 14:21:05 -0500 Subject: [PATCH 449/466] Implement . ignoring directly in test, because module suffixes has other uses --- compiler-lib/compiler/commands/test.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index c306eda2f7..e0c7e342b2 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -565,7 +565,8 @@ (directory-list p) #:sema continue-sema)))] [(and (or (not check-suffix?) - (regexp-match? rx:default-suffixes (file-name-from-path p)) + (and (regexp-match? rx:default-suffixes p) + (not (regexp-match? #rx"^[.]" (file-name-from-path p)))) (get-cmdline p #f #:check-info? #t) (include-path? p #:check-info? #t)) (or (not check-suffix?) From 423feb1e210b96f7f510b0a61b8d6f182be77117 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 3 Jan 2016 06:40:14 -0700 Subject: [PATCH 450/466] fix unmarshal of top-level "root" scope Closes #9 --- zo-lib/compiler/zo-parse.rkt | 99 +++++++++++++++++++----------------- 1 file changed, 51 insertions(+), 48 deletions(-) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 04010dbaf3..b3f25ab1a2 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -1175,7 +1175,7 @@ (struct-copy prefix p [stxs (map walk s)])] [(req rs _) (struct-copy req p - [reqs (map walk rs)])] + [reqs (walk rs)])] [(? mod?) (struct-copy mod p [prefix (walk (mod-prefix p))] @@ -1298,53 +1298,56 @@ [_ (error 'decode-wrap "bad shift")])))) (define (decode-scope s ht) - (hash-ref ht s - (lambda () - (unless (encoded-scope? s) - (error 'decode-wrap "bad scope: ~e" s)) - (define v (encoded-scope-content s)) - (define kind - (match v - [(? number?) v] - [(cons (? number?) _) - (car v)] - [else (error 'decode-wrap "bad scope")])) - (define sc (scope (encoded-scope-relative-id s) - (case kind - [(0 1) 'module] - [(2) 'macro] - [(3) 'local] - [(4) 'intdef] - [else 'use-site]) - null - null - #f)) - (hash-set! ht s sc) - (unless (number? v) - (define-values (bulk-bindings end) - (let loop ([l (cdr v)] [bulk-bindings null]) - (cond - [(pair? l) - (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) - (decode-bulk-import (cdar l) ht)) - bulk-bindings))] - [else (values (reverse bulk-bindings) l)]))) - (set-scope-bulk-bindings! sc bulk-bindings) - (unless (and (vector? end) - (even? (vector-length end))) - (error 'decode-wrap "bad scope")) - (define bindings - (let loop ([i 0]) - (cond - [(= i (vector-length end)) null] - [else - (append (for/list ([p (in-list (vector-ref end (add1 i)))]) - (list (vector-ref end i) - (decode-scope-set (car p) ht) - (decode-binding (cdr p) ht))) - (loop (+ i 2)))]))) - (set-scope-bindings! sc bindings)) - sc))) + (or + (and (eq? s root-scope) + s) + (hash-ref ht s + (lambda () + (unless (encoded-scope? s) + (error 'decode-wrap "bad scope: ~e" s)) + (define v (encoded-scope-content s)) + (define kind + (match v + [(? number?) v] + [(cons (? number?) _) + (car v)] + [else (error 'decode-wrap "bad scope")])) + (define sc (scope (encoded-scope-relative-id s) + (case kind + [(0 1) 'module] + [(2) 'macro] + [(3) 'local] + [(4) 'intdef] + [else 'use-site]) + null + null + #f)) + (hash-set! ht s sc) + (unless (number? v) + (define-values (bulk-bindings end) + (let loop ([l (cdr v)] [bulk-bindings null]) + (cond + [(pair? l) + (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) + (decode-bulk-import (cdar l) ht)) + bulk-bindings))] + [else (values (reverse bulk-bindings) l)]))) + (set-scope-bulk-bindings! sc bulk-bindings) + (unless (and (vector? end) + (even? (vector-length end))) + (error 'decode-wrap "bad scope")) + (define bindings + (let loop ([i 0]) + (cond + [(= i (vector-length end)) null] + [else + (append (for/list ([p (in-list (vector-ref end (add1 i)))]) + (list (vector-ref end i) + (decode-scope-set (car p) ht) + (decode-binding (cdr p) ht))) + (loop (+ i 2)))]))) + (set-scope-bindings! sc bindings)) + sc)))) (define (decode-scope-set l ht) (decode-map decode-scope l ht)) From d60185045c1b8b48335e6a141dcc284a02cf7ad3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 3 Jan 2016 06:44:07 -0700 Subject: [PATCH 451/466] compiler/zo-marshal: enable marshal of top-level `require` --- zo-lib/compiler/zo-marshal.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index d6eb6fbf82..593adf2760 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -705,7 +705,6 @@ [(struct splice (forms)) (out-marshaled splice-sequence-type-num forms out)] [(struct req (reqs dummy)) - (error "cannot handle top-level `require', yet") (out-marshaled require-form-type-num (cons dummy reqs) out)] [(struct toplevel (depth pos const? ready?)) (out-marshaled toplevel-type-num From 73a010841f95b50ca90ef44d0fca2666ebeb821b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 4 Jan 2016 10:59:17 -0700 Subject: [PATCH 452/466] add `raco exe` test with `place` --- .../tests/compiler/embed/embed-me28.rkt | 14 ++++++++++++ compiler-test/tests/compiler/embed/test.rkt | 22 +++++++++++++------ 2 files changed, 29 insertions(+), 7 deletions(-) create mode 100644 compiler-test/tests/compiler/embed/embed-me28.rkt diff --git a/compiler-test/tests/compiler/embed/embed-me28.rkt b/compiler-test/tests/compiler/embed/embed-me28.rkt new file mode 100644 index 0000000000..426a4aa503 --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me28.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require racket/place) + +(define (go) + (place pch + (place-channel-put pch 28))) + +(module+ main + (define p (go)) + (define n (place-channel-get p)) + (void (place-wait p)) + (with-output-to-file (build-path (find-system-path 'temp-dir) "stdout") + (lambda () (printf "~a\n" n)) + #:exists 'append)) diff --git a/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt index 1bbcacd1f9..ee4d4362e6 100644 --- a/compiler-test/tests/compiler/embed/test.rkt +++ b/compiler-test/tests/compiler/embed/test.rkt @@ -354,6 +354,14 @@ (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me23.rkt"))) (try-exe (mk-dest mred?) "1\n2\n" mred?) + ;; raco exe on a module with `place` + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me28.rkt"))) + (try-exe (mk-dest mred?) "28\n" mred?) + ;; raco exe --launcher (system+ raco "exe" @@ -656,13 +664,13 @@ ;; ---------------------------------------- -(try-basic) -(try-mzc) -(try-extension) -(try-gracket) -(try-reader) -(try-planet) -(try-*sl) +;(try-basic) +;(try-mzc) +;(try-extension) +;(try-gracket) +;(try-reader) +;(try-planet) +;(try-*sl) (try-source) ;; ---------------------------------------- From 12927d0e8bbbac5912d88fe06a96a827396d95b8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 9 Jan 2016 22:51:55 -0500 Subject: [PATCH 453/466] Avoid writing to the current directory in this test. --- compiler-test/tests/compiler/make.rkt | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/compiler-test/tests/compiler/make.rkt b/compiler-test/tests/compiler/make.rkt index e537e03b4a..d17d16cbb8 100644 --- a/compiler-test/tests/compiler/make.rkt +++ b/compiler-test/tests/compiler/make.rkt @@ -4,17 +4,17 @@ racket/system compiler/find-exe) -(define tmpdir (make-temporary-file "tmp~a" 'directory (current-directory))) -(define tmppath (build-path tmpdir "tmp.rkt")) -(with-output-to-file (build-path tmpdir "tmp.rkt") #:exists 'replace - (lambda () - (printf "#lang racket\n"))) -(define exec-path (find-exe)) -(define relpath (find-relative-path (current-directory) tmppath)) +(parameterize ((current-directory (find-system-path 'temp-dir))) + (define tmpdir (make-temporary-file "tmp~a" 'directory (current-directory))) + (define tmppath (build-path tmpdir "tmp.rkt")) + (with-output-to-file (build-path tmpdir "tmp.rkt") #:exists 'replace + (lambda () + (printf "#lang racket\n"))) + (define exec-path (find-exe)) + (define relpath (find-relative-path (current-directory) tmppath)) -(define ok? (system* exec-path "-l" "raco" "make" "-j" "2" (path->string relpath))) -(delete-directory/files tmpdir) - -(unless ok? - (error "`raco make` test failed")) + (define ok? (system* exec-path "-l" "raco" "make" "-j" "2" (path->string relpath))) + (delete-directory/files tmpdir) + (unless ok? + (error "`raco make` test failed"))) From db250c4cf9cbebf374699ced3e81bfa43b6a59e2 Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Tue, 28 Apr 2015 18:53:30 -0400 Subject: [PATCH 454/466] fixed -c error Closes #1. --- compiler-lib/compiler/commands/test.rkt | 6 ++++++ compiler-test/info.rkt | 1 + compiler-test/tests/compiler/commands/test.rkt | 5 +++++ 3 files changed, 12 insertions(+) create mode 100644 compiler-test/tests/compiler/commands/test.rkt diff --git a/compiler-lib/compiler/commands/test.rkt b/compiler-lib/compiler/commands/test.rkt index e0c7e342b2..7416398815 100644 --- a/compiler-lib/compiler/commands/test.rkt +++ b/compiler-lib/compiler/commands/test.rkt @@ -637,8 +637,12 @@ (module paths racket/base (require setup/link racket/match + setup/collection-name + raco/command-name racket/list) + (define test-exe-name (string->symbol (short-program+command-name))) + (struct col (name path) #:transparent) (define (get-linked file user? version?) @@ -681,6 +685,8 @@ ;; This should be in Racket somewhere and return all the collection ;; paths, rather than just the first as collection-path does. (define (collection-paths c) + (when (not (collection-name? c)) + (error test-exe-name "not a collection name in: ~a" c)) (match-define (list-rest sc more) (map path->string (explode-path c))) (append* (for/list ([col (all-collections)] diff --git a/compiler-test/info.rkt b/compiler-test/info.rkt index 225508f53c..a39c4d12de 100644 --- a/compiler-test/info.rkt +++ b/compiler-test/info.rkt @@ -9,6 +9,7 @@ (define pkg-authors '(mflatt)) (define build-deps '("compiler-lib" "eli-tester" + "rackunit-lib" "net-lib" "scheme-lib" "compatibility-lib" diff --git a/compiler-test/tests/compiler/commands/test.rkt b/compiler-test/tests/compiler/commands/test.rkt new file mode 100644 index 0000000000..62dbe1dbc7 --- /dev/null +++ b/compiler-test/tests/compiler/commands/test.rkt @@ -0,0 +1,5 @@ +#lang racket +(require rackunit) +(require (only-in (submod compiler/commands/test paths) collection-paths)) + +(check-exn exn? (lambda () (collection-paths "."))) From 0435a3639dbd5f58c52f49421a3c295746c161c2 Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Sun, 10 Jan 2016 09:58:31 -0600 Subject: [PATCH 455/466] fixed call to cover in travis build --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 478923d4ac..7231d831aa 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,4 +29,4 @@ install: script: - raco test -p $PKG-test -- raco cover -c coveralls $TRAVIS_BUILD_DIR/coverage . +- raco cover -f coveralls $TRAVIS_BUILD_DIR/coverage . From 220ee74abeb13e9d64907062eeb45d534c0eef6d Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Sun, 10 Jan 2016 10:06:15 -0600 Subject: [PATCH 456/466] added correct deps for cover --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 7231d831aa..fd40319e30 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,7 +24,7 @@ install: - raco pkg config --set catalogs `cat catalog-config.txt` - raco pkg install -i --deps search-auto $PKG-test - raco pkg install -i --deps search-auto compiler-lib -- raco pkg install -i --deps search-auto cover +- raco pkg install -i --deps search-auto cover-coveralls - ls $HOME/.racket/download-cache script: From 0fbf0343b94c68a43e30fe923af8caaac29494f6 Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Sun, 10 Jan 2016 10:16:22 -0600 Subject: [PATCH 457/466] fixed more cover flags --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index fd40319e30..fd711afd96 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,4 +29,4 @@ install: script: - raco test -p $PKG-test -- raco cover -f coveralls $TRAVIS_BUILD_DIR/coverage . +- raco cover -f coveralls -d $TRAVIS_BUILD_DIR/coverage . From 6261cc5f1843b6e368a550260c8804e8ead0ddfc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 11 Jan 2016 15:39:33 -0500 Subject: [PATCH 458/466] Correctly use installation scope everywhere. --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index fd711afd96..1eb8409d51 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,8 +20,8 @@ before_install: install: - racket -l- pkg/dirs-catalog --link --check-metadata pkgs-catalog . - echo file://`pwd`/pkgs-catalog/ > catalog-config.txt -- raco pkg config catalogs >> catalog-config.txt -- raco pkg config --set catalogs `cat catalog-config.txt` +- raco pkg config -i catalogs >> catalog-config.txt +- raco pkg config -i --set catalogs `cat catalog-config.txt` - raco pkg install -i --deps search-auto $PKG-test - raco pkg install -i --deps search-auto compiler-lib - raco pkg install -i --deps search-auto cover-coveralls From 865ecfb159ab110309670d7380d4a6458c271813 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Jan 2016 20:21:53 -0700 Subject: [PATCH 459/466] restore tests Accidentally left commented out in 73a010841f. --- compiler-test/tests/compiler/embed/test.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt index ee4d4362e6..d5e6dfb86e 100644 --- a/compiler-test/tests/compiler/embed/test.rkt +++ b/compiler-test/tests/compiler/embed/test.rkt @@ -664,13 +664,13 @@ ;; ---------------------------------------- -;(try-basic) -;(try-mzc) -;(try-extension) -;(try-gracket) -;(try-reader) -;(try-planet) -;(try-*sl) +(try-basic) +(try-mzc) +(try-extension) +(try-gracket) +(try-reader) +(try-planet) +(try-*sl) (try-source) ;; ---------------------------------------- From f4beeeb7e11fdead35c7fa18fada349ef699059c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 5 Feb 2016 17:58:59 -0500 Subject: [PATCH 460/466] Increase timeout. --- compiler-test/tests/compiler/embed/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler-test/tests/compiler/embed/info.rkt b/compiler-test/tests/compiler/embed/info.rkt index 5f50add10e..618b4d7f48 100644 --- a/compiler-test/tests/compiler/embed/info.rkt +++ b/compiler-test/tests/compiler/embed/info.rkt @@ -17,6 +17,6 @@ "embed-planet-1" "embed-planet-2")) -(define test-timeouts '(("test.rkt" 600))) +(define test-timeouts '(("test.rkt" 900))) (define test-responsibles '((all mflatt))) From 2a1dd00320ebe8a364302580c5a6894322ef5c60 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Feb 2016 06:44:39 -0700 Subject: [PATCH 461/466] bytecode updates for v6.4.0.8 --- zo-lib/compiler/zo-marshal.rkt | 4 ++-- zo-lib/compiler/zo-parse.rkt | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 593adf2760..5066aa3d49 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -293,8 +293,8 @@ (define case-lambda-sequence-type-num 26) (define module-type-num 27) (define inline-variants-type-num 28) -(define variable-type-num 36) -(define prefix-type-num 121) +(define variable-type-num 37) +(define prefix-type-num 122) (define-syntax define-enum (syntax-rules () diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index b3f25ab1a2..0aab000460 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -389,9 +389,9 @@ [(26) 'case-lambda-sequence-type] [(27) 'module-type] [(28) 'inline-variant-type] - [(36) 'variable-type] - [(37) 'module-variable-type] - [(121) 'resolve-prefix-type] + [(37) 'variable-type] + [(38) 'module-variable-type] + [(122) 'resolve-prefix-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers From 209a4ff6310da044391dd242ede9fd5199be8800 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 Mar 2016 05:49:05 -0700 Subject: [PATCH 462/466] decompile: avoid single-subexpression `begin0` At the bytecode level, `(begin0 E)` does not make E in tail position with respect to the `begin0` form. It does at the source level, so generate suitable source. --- compiler-lib/compiler/decompile.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index fc5ce2ad82..a393218fff 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -505,8 +505,11 @@ `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) - `(begin0 ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack closed)))] + `(begin0 + ,@(for/list ([expr (in-list exprs)]) + (decompile-expr expr globs stack closed)) + ;; Make sure a single expression doesn't look like tail position: + ,@(if (null? (cdr exprs)) (list #f) null))] [(struct with-cont-mark (key val body)) `(with-continuation-mark ,(decompile-expr key globs stack closed) From 976c5e6e2bb5fb223ca700b7c2b851e3f866125f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 9 Mar 2016 19:35:02 -0700 Subject: [PATCH 463/466] zo parse & marshal updates for preserved syntax properties --- zo-lib/compiler/zo-marshal.rkt | 20 +++++++++++++++++--- zo-lib/compiler/zo-parse.rkt | 17 +++++++++++------ 2 files changed, 28 insertions(+), 9 deletions(-) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 5066aa3d49..d2d55248f3 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -431,12 +431,26 @@ [esrcloc (let () (define (avail? n) (n . >= . 0)) (define (xvector a b c d e) + ;; Add paren-shape info, if any: (case (hash-ref props 'paren-shape #f) - [(#\[) (vector a b c d e #\[)] - [(#\{) (vector a b c d e #\{)] + [(#\[) (yvector a b c d e #\[)] + [(#\{) (yvector a b c d e #\{)] [else (if (or a (avail? b) (avail? c) (avail? d)) - (vector a b c d e) + (yvector a b c d e #f) #f)])) + (define (yvector a b c d e f) + ;; Add properties, if any: + (if (positive? (- (hash-count props) (if f 1 0))) + (vector a b c d e f + (sort (for/list ([(k v) (in-hash props)] + #:unless (and f + (eq? k 'paren-shape))) + (cons k v)) + symbol . 5)) - (case (vector-ref esrcloc 5) - [(#\[) #hasheq((paren-shape . #\[))] - [(#\{) #hasheq((paren-shape . #\{))] - [else #hasheq()]) - #hasheq()))))) + (let ([props + (if (and esrcloc ((vector-length esrcloc) . > . 5)) + (case (vector-ref esrcloc 5) + [(#\[) #hasheq((paren-shape . #\[))] + [(#\{) #hasheq((paren-shape . #\{))] + [else #hasheq()]) + #hasheq())]) + (if (and esrcloc ((vector-length esrcloc) . > . 6)) + (for/fold ([props props]) ([p (in-list (vector-ref esrcloc 6))]) + (hash-set props (car p) (cdr p))) + props)))))) (values (car p) (cdr p))) ;; ---------------------------------------- From 6a5b7ae9f966bf7aa10a59846441d975a7aeb3ac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 1 Apr 2016 16:23:00 -0600 Subject: [PATCH 464/466] add `raco exe` test for a submodule reference from a submodule --- compiler-test/tests/compiler/embed/embed-me29-2.rkt | 5 +++++ compiler-test/tests/compiler/embed/embed-me29.rkt | 5 +++++ compiler-test/tests/compiler/embed/test.rkt | 8 ++++++++ 3 files changed, 18 insertions(+) create mode 100644 compiler-test/tests/compiler/embed/embed-me29-2.rkt create mode 100644 compiler-test/tests/compiler/embed/embed-me29.rkt diff --git a/compiler-test/tests/compiler/embed/embed-me29-2.rkt b/compiler-test/tests/compiler/embed/embed-me29-2.rkt new file mode 100644 index 0000000000..28be26231b --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me29-2.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(module inside racket/base + (define inside 'inside) + (provide inside)) diff --git a/compiler-test/tests/compiler/embed/embed-me29.rkt b/compiler-test/tests/compiler/embed/embed-me29.rkt new file mode 100644 index 0000000000..be6b4c3a3e --- /dev/null +++ b/compiler-test/tests/compiler/embed/embed-me29.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(module main racket/base + (require (submod "embed-me29-2.rkt" inside)) + inside) diff --git a/compiler-test/tests/compiler/embed/test.rkt b/compiler-test/tests/compiler/embed/test.rkt index d5e6dfb86e..2659443059 100644 --- a/compiler-test/tests/compiler/embed/test.rkt +++ b/compiler-test/tests/compiler/embed/test.rkt @@ -339,6 +339,14 @@ (try-exe (mk-dest mred?) "This is 20.\n" mred?) ;; raco exe on a module with a `configure-runtime' submodule + (system+ raco + "exe" + "-o" (path->string (mk-dest mred?)) + (if mred? "--gui" "--") + (path->string (build-path (collection-path "tests" "compiler" "embed") "embed-me29.rkt"))) + (try-exe (mk-dest mred?) "'inside\n" mred?) + + ;; raco exe on a module with a submodule that references another file's submodule (system+ raco "exe" "-o" (path->string (mk-dest mred?)) From a1ba579666adb50dee6221c7d7cc07a49e2a5254 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 27 Mar 2016 16:21:41 -0500 Subject: [PATCH 465/466] avoid defeating an optimization in the loggging code during `raco make` --- compiler-lib/compiler/commands/make.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler-lib/compiler/commands/make.rkt b/compiler-lib/compiler/commands/make.rkt index 3bc0ec7ed8..f9b7f3a611 100644 --- a/compiler-lib/compiler/commands/make.rkt +++ b/compiler-lib/compiler/commands/make.rkt @@ -70,9 +70,9 @@ [did-one? #f]) (parameterize ([current-namespace n] [manager-trace-handler - (lambda (p) - (when (very-verbose) - (printf " ~a\n" p)))] + (if (very-verbose) + (λ (p) (printf " ~a\n" p)) + (manager-trace-handler))] [manager-compile-notify-handler (lambda (p) (set! did-one? #t) From f2b76a675ae8461df982ff52d2289f4ffa4277a1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Apr 2016 08:07:44 -0600 Subject: [PATCH 466/466] make `raco exe -l` cooperate with tethered-executable builds The configuration of an addon-tethered directory is treated as a sign that access to collections in the "user" space should be accessible by default in a launcher, as well as propagating the addon-directory setting to the launched program. --- compiler-lib/compiler/commands/exe.rkt | 13 ++++++++++++- compiler-lib/info.rkt | 2 +- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/compiler-lib/compiler/commands/exe.rkt b/compiler-lib/compiler/commands/exe.rkt index 305879651f..023ef4d671 100644 --- a/compiler-lib/compiler/commands/exe.rkt +++ b/compiler-lib/compiler/commands/exe.rkt @@ -3,7 +3,8 @@ raco/command-name compiler/private/embed launcher/launcher - dynext/file) + dynext/file + setup/dirs) (define verbose (make-parameter #f)) (define very-verbose (make-parameter #f)) @@ -29,6 +30,16 @@ [("--gui") "Generate GUI executable" (gui #t)] [("-l" "--launcher") "Generate a launcher" + (when (or (find-addon-tethered-gui-bin-dir) + (find-addon-tethered-console-bin-dir)) + ;; When an addon-executable directory is configured, treat the + ;; addon directory more like an installation directory, instead + ;; of a user-specific directory: record it, and remove the -U + ;; flag (if any) + (exe-embedded-flags + (append + (list "-A" (path->string (find-system-path 'addon-dir))) + (remove "-U" (exe-embedded-flags))))) (launcher #t)] [("--config-path") path "Set as configuration directory for executable" (exe-embedded-config-path path)] diff --git a/compiler-lib/info.rkt b/compiler-lib/info.rkt index 4cbd2611a5..cce80f1f4a 100644 --- a/compiler-lib/info.rkt +++ b/compiler-lib/info.rkt @@ -2,7 +2,7 @@ (define collection 'multi) -(define deps '(["base" #:version "6.2.900.10"] +(define deps '(["base" #:version "6.5.0.2"] "scheme-lib" "rackunit-lib" "zo-lib"))