Re-organize code so that with-compilation-unit can infer

Fix with-compilation-unit to work in deployed code

basis/bootstrap/image/image.factor

@@ -515,7 +515,7 @@ M: quotation '
     20000 <hashtable> objects set
     emit-header t, 0, 1, -1,
     "Building generic words..." print flush
-    call-remake-generics-hook
+    remake-generics
     "Serializing words..." print flush
     emit-words
     "Serializing JIT data..." print flush

basis/compiler/compiler-docs.factor

@@ -12,8 +12,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Normally, new word definitions are recompiled automatically. This can be changed:"
 { $subsection disable-compiler }
 { $subsection enable-compiler }
-"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
-{ $subsection optimized-recompile-hook }
 "Removing a word's optimized definition:"
 { $subsection decompile }
 "Compiling a single quotation:"
@@ -46,9 +44,8 @@ HELP: (compile)
 { $description "Compile a single word." }
 { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
 
-HELP: optimized-recompile-hook
+HELP: optimizing-compiler
-{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
+{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
-{ $description "Compile a set of words." }
 { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
 
 HELP: compile-call

basis/compiler/compiler.factor

@@ -111,7 +111,7 @@ t compile-dependencies? set-global
     ] with-return ;
 
 : compile-loop ( deque -- )
-    [ (compile) yield-hook get call ] slurp-deque ;
+    [ (compile) yield-hook get assert-depth ] slurp-deque ;
 
 : decompile ( word -- )
     f 2array 1array modify-code-heap ;
@@ -119,7 +119,9 @@ t compile-dependencies? set-global
 : compile-call ( quot -- )
     [ dup infer define-temp ] with-compilation-unit execute ;
 
-: optimized-recompile-hook ( words -- alist )
+SINGLETON: optimizing-compiler
+
+M: optimizing-compiler recompile ( words -- alist )
     [
         <hashed-dlist> compile-queue set
         H{ } clone compiled set
@@ -129,10 +131,10 @@ t compile-dependencies? set-global
     ] with-scope ;
 
 : enable-compiler ( -- )
-    [ optimized-recompile-hook ] recompile-hook set-global ;
+    optimizing-compiler compiler-impl set-global ;
 
 : disable-compiler ( -- )
-    [ default-recompile-hook ] recompile-hook set-global ;
+    f compiler-impl set-global ;
 
 : recompile-all ( -- )
     forget-errors all-words compile ;

basis/cpu/x86/32/32.factor

@@ -309,8 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
     check_sse2 ;
 
 "-no-sse2" (command-line) member? [
-    [ optimized-recompile-hook ] recompile-hook
+    optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
-    [ { check_sse2 } compile ] with-variable
 
     "Checking if your CPU supports SSE2..." print flush
     sse2? [

basis/tools/deploy/shaker/shaker.factor

@@ -53,6 +53,13 @@ IN: tools.deploy.shaker
         run-file
     ] when ;
 
+: strip-call ( -- )
+    "call" vocab [
+        "Stripping stack effect checking from call( and execute(" show
+        "vocab:tools/deploy/shaker/strip-call.factor"
+        run-file
+    ] when ;
+
 : strip-cocoa ( -- )
     "cocoa" vocab [
         "Stripping unused Cocoa methods" show
@@ -256,9 +263,7 @@ IN: tools.deploy.shaker
                 command-line:main-vocab-hook
                 compiled-crossref
                 compiled-generic-crossref
-                recompile-hook
+                compiler-impl
-                update-tuples-hook
-                remake-generics-hook
                 definition-observers
                 definitions:crossref
                 interactive-vocabs
@@ -399,6 +404,7 @@ SYMBOL: deploy-vocab
     init-stripper
     strip-default-methods
     strip-libc
+    strip-call
     strip-cocoa
     strip-debugger
     compute-next-methods

basis/tools/deploy/shaker/strip-call.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: tools.deploy.shaker.call
+
+IN: call
+USE: call.private
+
+: execute-effect ( word effect -- ) execute-effect-unsafe ; inline

core/bootstrap/primitives.factor

@@ -36,7 +36,7 @@ H{ } clone sub-primitives set
     dictionary
     new-classes
     changed-definitions changed-generics
-    remake-generics forgotten-definitions
+    outdated-generics forgotten-definitions
     root-cache source-files update-map implementors-map
 } [ H{ } clone swap set ] each
 
@@ -47,8 +47,10 @@ init-caches
 
 ! Trivial recompile hook. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.
+! SINGLETON: dummy-compiler
+! M: dummy-compiler recompile drop { } ;
+! dummy-compiler compiler-impl set
 [ drop { } ] recompile-hook set
-
 call
 call
 call

core/classes/tuple/tuple.factor

@@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel kernel.private math
 namespaces make sequences sequences.private strings vectors
 words quotations memory combinators generic classes
 classes.algebra classes.builtin classes.private slots.private
-slots compiler.units math.private accessors assocs effects ;
+slots math.private accessors assocs effects ;
 IN: classes.tuple
 
 PREDICATE: tuple-class < class
@@ -188,6 +188,8 @@ ERROR: bad-superclass class ;
 : apply-slot-permutation ( old-values triples -- new-values )
     [ first3 update-slot ] with map ;
 
+SYMBOL: outdated-tuples
+
 : permute-slots ( old-values layout -- new-values )
     [ first all-slots ] [ outdated-tuples get at ] bi
     compute-slot-permutation
@@ -212,8 +214,6 @@ ERROR: bad-superclass class ;
         dup [ update-tuple ] map become
     ] if ;
 
-[ update-tuples ] update-tuples-hook set-global
-
 : update-tuples-after ( class -- )
     [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
 

core/compiler/units/units-docs.factor

@@ -17,7 +17,7 @@ $nl
 "Forward reference checking (see " { $link "definition-checking" } "):"
 { $subsection forward-reference? }
 "A hook to be called at the end of the compilation unit. If the optimizing compiler is loaded, this compiles new words with the " { $link "compiler" } ":"
-{ $subsection recompile-hook }
+{ $subsection recompile }
 "Low-level compiler interface exported by the Factor VM:"
 { $subsection modify-code-heap } ;
 
@@ -47,8 +47,9 @@ $nl
 $nl
 "Since compilation is relatively expensive, you should try to batch up as many definitions into one compilation unit as possible." } ;
 
-HELP: recompile-hook
+HELP: recompile
-{ $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ;
+{ $values { "words" "a sequence of words" } { "alist" "an association list mapping words to compiled definitions" } }
+{ $contract "Internal word which compiles words. Called at the end of " { $link with-compilation-unit } "." } ;
 
 HELP: no-compilation-unit
 { $values { "word" word } }

core/compiler/units/units-tests.factor

@@ -2,6 +2,9 @@ IN: compiler.units.tests
 USING: definitions compiler.units tools.test arrays sequences words kernel
 accessors namespaces fry ;
 
+[ [ [ ] define-temp ] with-compilation-unit ] must-infer
+[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
+
 [ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
 [ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
 [ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test

core/compiler/units/units.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel continuations assocs namespaces
 sequences words vocabs definitions hashtables init sets
-math math.order classes classes.algebra ;
+math math.order classes classes.algebra classes.tuple
+classes.tuple.private generic ;
 IN: compiler.units
 
 SYMBOL: old-definitions
@@ -35,7 +36,11 @@ TUPLE: redefine-error def ;
     [ new-definitions get assoc-stack not ]
     [ drop f ] if ;
 
-SYMBOL: recompile-hook
+SYMBOL: compiler-impl
+
+HOOK: recompile compiler-impl ( words -- alist )
+
+M: f recompile [ f ] { } map>assoc ;
 
 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
 
@@ -68,12 +73,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     dup changed-definitions get update
     dup dup changed-vocabs update ;
 
-: compile ( words -- )
+: compile ( words -- ) recompile modify-code-heap ;
-    recompile-hook get call modify-code-heap ;
-
-SYMBOL: outdated-tuples
-SYMBOL: update-tuples-hook
-SYMBOL: remake-generics-hook
 
 : index>= ( obj1 obj2 seq -- ? )
     [ index ] curry bi@ >= ;
@@ -125,24 +125,15 @@ SYMBOL: remake-generics-hook
     changed-generics get compiled-generic-usages
     append assoc-combine keys ;
 
-: call-recompile-hook ( -- )
-    to-recompile recompile-hook get call ;
-
-: call-remake-generics-hook ( -- )
-    remake-generics-hook get call ;
-
-: call-update-tuples-hook ( -- )
-    update-tuples-hook get call ;
-
 : unxref-forgotten-definitions ( -- )
     forgotten-definitions get
     keys [ word? ] filter
     [ delete-compiled-xref ] each ;
 
 : finish-compilation-unit ( -- )
-    call-remake-generics-hook
+    remake-generics
-    call-recompile-hook
+    to-recompile recompile
-    call-update-tuples-hook
+    update-tuples
     unxref-forgotten-definitions
     modify-code-heap ;
 
@@ -150,7 +141,7 @@ SYMBOL: remake-generics-hook
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
-        H{ } clone remake-generics set
+        H{ } clone outdated-generics set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
         [ finish-compilation-unit ] [ ] cleanup
@@ -160,7 +151,7 @@ SYMBOL: remake-generics-hook
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
-        H{ } clone remake-generics set
+        H{ } clone outdated-generics set
         H{ } clone forgotten-definitions set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
@@ -172,8 +163,3 @@ SYMBOL: remake-generics-hook
             notify-definition-observers
         ] [ ] cleanup
     ] with-scope ; inline
-
-: default-recompile-hook ( words -- alist )
-    [ f ] { } map>assoc ;
-
-recompile-hook [ [ default-recompile-hook ] ] initialize

core/definitions/definitions.factor

@@ -19,7 +19,7 @@ SYMBOL: changed-definitions
 
 SYMBOL: changed-generics
 
-SYMBOL: remake-generics
+SYMBOL: outdated-generics
 
 SYMBOL: new-classes
 

core/generic/generic.factor

@@ -3,7 +3,7 @@
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
 classes.algebra quotations arrays vocabs effects combinators
-sets compiler.units ;
+sets ;
 IN: generic
 
 ! Method combination protocol
@@ -21,11 +21,6 @@ M: generic definition drop f ;
     [ dup "combination" word-prop perform-combination ]
     bi ;
 
-[
-    remake-generics get keys
-    [ generic? ] filter [ make-generic ] each
-] remake-generics-hook set-global
-
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -76,7 +71,10 @@ TUPLE: check-method class generic ;
     [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
 
 : remake-generic ( generic -- )
-    dup remake-generics get set-in-unit ;
+    dup outdated-generics get set-in-unit ;
+
+: remake-generics ( -- )
+    outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
 
 : with-methods ( class generic quot -- )
     [ drop changed-generic ]