stack-checker: using cleanup.
							parent
							
								
									a8b3642c8c
								
							
						
					
					
						commit
						31ecc5ef86
					
				| 
						 | 
				
			
			@ -1,11 +1,10 @@
 | 
			
		|||
! Copyright (C) 2008, 2010 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: kernel destructors arrays sequences accessors combinators math
 | 
			
		||||
namespaces init sets words assocs alien.libraries alien
 | 
			
		||||
alien.private alien.c-types fry quotations strings
 | 
			
		||||
stack-checker.backend stack-checker.errors stack-checker.visitor
 | 
			
		||||
USING: accessors alien alien.c-types alien.libraries
 | 
			
		||||
alien.private arrays assocs combinators effects fry kernel math
 | 
			
		||||
namespaces quotations sequences stack-checker.backend
 | 
			
		||||
stack-checker.dependencies stack-checker.state
 | 
			
		||||
compiler.utilities effects ;
 | 
			
		||||
stack-checker.visitor strings words ;
 | 
			
		||||
FROM: kernel.private => declare ;
 | 
			
		||||
IN: stack-checker.alien
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -129,12 +128,11 @@ wait-for-callback-hook [ [ drop ] ] initialize
 | 
			
		|||
M: callable wrap-callback-quot
 | 
			
		||||
    swap [ callback-parameter-quot ] [ callback-return-quot ] bi surround
 | 
			
		||||
    wait-for-callback-hook get
 | 
			
		||||
    '[ _ _ do-callback ]
 | 
			
		||||
    >quotation ;
 | 
			
		||||
    '[ _ _ do-callback ] >quotation ;
 | 
			
		||||
 | 
			
		||||
: callback-effect ( params -- effect )
 | 
			
		||||
    [ parameters>> length "x" <array> ] [ return>> void? { } { "x" } ? ] bi
 | 
			
		||||
    <effect> ;
 | 
			
		||||
    [ parameters>> length "x" <array> ]
 | 
			
		||||
    [ return>> void? { } { "x" } ? ] bi <effect> ;
 | 
			
		||||
 | 
			
		||||
: infer-callback-quot ( params quot -- child )
 | 
			
		||||
    [
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,11 +1,10 @@
 | 
			
		|||
! Copyright (C) 2004, 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: fry arrays generic io io.streams.string kernel math namespaces
 | 
			
		||||
parser sequences strings vectors words quotations effects classes
 | 
			
		||||
continuations assocs combinators compiler.errors accessors math.order
 | 
			
		||||
definitions locals sets hints macros stack-checker.state
 | 
			
		||||
stack-checker.visitor stack-checker.errors stack-checker.values
 | 
			
		||||
stack-checker.recursive-state stack-checker.dependencies summary ;
 | 
			
		||||
USING: accessors arrays effects fry kernel locals math
 | 
			
		||||
math.order namespaces quotations sequences
 | 
			
		||||
stack-checker.dependencies stack-checker.errors
 | 
			
		||||
stack-checker.recursive-state stack-checker.state
 | 
			
		||||
stack-checker.values stack-checker.visitor words ;
 | 
			
		||||
FROM: sequences.private => from-end ;
 | 
			
		||||
FROM: namespaces => set ;
 | 
			
		||||
IN: stack-checker.backend
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,9 +1,10 @@
 | 
			
		|||
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
 | 
			
		||||
combinators quotations namespaces grouping locals stack-checker.state
 | 
			
		||||
stack-checker.backend stack-checker.errors stack-checker.visitor
 | 
			
		||||
stack-checker.values stack-checker.recursive-state ;
 | 
			
		||||
USING: accessors arrays assocs effects fry grouping kernel math
 | 
			
		||||
namespaces quotations sequences stack-checker.backend
 | 
			
		||||
stack-checker.errors stack-checker.recursive-state
 | 
			
		||||
stack-checker.state stack-checker.values stack-checker.visitor
 | 
			
		||||
vectors ;
 | 
			
		||||
FROM: sequences.private => dispatch ;
 | 
			
		||||
IN: stack-checker.branches
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,8 +1,8 @@
 | 
			
		|||
! Copyright (C) 2009, 2010 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: arrays assocs accessors classes classes.algebra fry
 | 
			
		||||
generic kernel math namespaces sequences words sets
 | 
			
		||||
combinators.short-circuit classes.tuple alien.c-types ;
 | 
			
		||||
USING: accessors alien.c-types arrays classes classes.algebra
 | 
			
		||||
classes.tuple combinators.short-circuit fry generic kernel math
 | 
			
		||||
namespaces sequences sets words ;
 | 
			
		||||
FROM: classes.tuple.private => tuple-layout ;
 | 
			
		||||
FROM: assocs => change-at ;
 | 
			
		||||
FROM: namespaces => set ;
 | 
			
		||||
| 
						 | 
				
			
			@ -17,8 +17,11 @@ SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
 | 
			
		|||
    [ index ] curry bi@ >= ;
 | 
			
		||||
 | 
			
		||||
: dependency>= ( how1 how2 -- ? )
 | 
			
		||||
    { effect-dependency conditional-dependency definition-dependency }
 | 
			
		||||
    index>= ;
 | 
			
		||||
    {
 | 
			
		||||
        effect-dependency
 | 
			
		||||
        conditional-dependency
 | 
			
		||||
        definition-dependency
 | 
			
		||||
    } index>= ;
 | 
			
		||||
 | 
			
		||||
: strongest-dependency ( how1 how2 -- how )
 | 
			
		||||
    [ effect-dependency or ] bi@ [ dependency>= ] most ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,7 @@
 | 
			
		|||
! Copyright (C) 2008, 2010 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: accessors arrays kernel prettyprint io debugger
 | 
			
		||||
sequences assocs stack-checker.errors summary effects ;
 | 
			
		||||
USING: accessors arrays debugger io kernel prettyprint sequences
 | 
			
		||||
stack-checker.errors summary ;
 | 
			
		||||
IN: stack-checker.errors.prettyprint
 | 
			
		||||
 | 
			
		||||
M: unknown-macro-input summary
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,18 +1,11 @@
 | 
			
		|||
! Copyright (C) 2008, 2010 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: fry namespaces assocs kernel sequences words accessors
 | 
			
		||||
definitions math math.order effects classes arrays combinators
 | 
			
		||||
vectors hints
 | 
			
		||||
stack-checker.state
 | 
			
		||||
stack-checker.errors
 | 
			
		||||
stack-checker.values
 | 
			
		||||
stack-checker.visitor
 | 
			
		||||
stack-checker.backend
 | 
			
		||||
stack-checker.branches
 | 
			
		||||
stack-checker.known-words
 | 
			
		||||
stack-checker.dependencies
 | 
			
		||||
stack-checker.row-polymorphism
 | 
			
		||||
stack-checker.recursive-state ;
 | 
			
		||||
USING: accessors arrays effects fry hints kernel math math.order
 | 
			
		||||
namespaces sequences stack-checker.backend
 | 
			
		||||
stack-checker.dependencies stack-checker.errors
 | 
			
		||||
stack-checker.known-words stack-checker.recursive-state
 | 
			
		||||
stack-checker.state stack-checker.values stack-checker.visitor
 | 
			
		||||
vectors words ;
 | 
			
		||||
IN: stack-checker.inlining
 | 
			
		||||
 | 
			
		||||
! Code to handle inline words. Much of the complexity stems from
 | 
			
		||||
| 
						 | 
				
			
			@ -107,8 +100,9 @@ SYMBOL: enter-out
 | 
			
		|||
    [ terminate ] when ;
 | 
			
		||||
 | 
			
		||||
: check-call-height ( label -- )
 | 
			
		||||
    dup entry-stack-height current-stack-height >
 | 
			
		||||
    [ word>> diverging-recursion-error inference-error ] [ drop ] if ;
 | 
			
		||||
    dup entry-stack-height current-stack-height > [
 | 
			
		||||
        word>> diverging-recursion-error inference-error
 | 
			
		||||
    ] [ drop ] if ;
 | 
			
		||||
 | 
			
		||||
: trim-stack ( label seq -- stack )
 | 
			
		||||
    swap word>> required-stack-effect in>> length tail* ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,31 +1,21 @@
 | 
			
		|||
! Copyright (C) 2004, 2011 Slava Pestov, Daniel Ehrenberg.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: fry accessors alien alien.accessors alien.private arrays
 | 
			
		||||
byte-arrays classes continuations.private effects generic
 | 
			
		||||
hashtables hashtables.private io io.backend io.files
 | 
			
		||||
io.files.private io.streams.c kernel kernel.private math
 | 
			
		||||
math.private math.parser.private memory memory.private
 | 
			
		||||
namespaces namespaces.private parser quotations
 | 
			
		||||
quotations.private sbufs sbufs.private sequences
 | 
			
		||||
sequences.private slots.private strings strings.private system
 | 
			
		||||
threads.private classes.tuple classes.tuple.private vectors
 | 
			
		||||
vectors.private words words.private definitions assocs summary
 | 
			
		||||
compiler.units system.private combinators tools.memory.private
 | 
			
		||||
combinators.short-circuit locals locals.backend locals.types
 | 
			
		||||
combinators.private stack-checker.values generic.single
 | 
			
		||||
generic.single.private alien.libraries tools.dispatch.private
 | 
			
		||||
macros tools.profiler.sampling.private classes.algebra
 | 
			
		||||
stack-checker.alien
 | 
			
		||||
stack-checker.state
 | 
			
		||||
stack-checker.errors
 | 
			
		||||
stack-checker.visitor
 | 
			
		||||
stack-checker.backend
 | 
			
		||||
stack-checker.branches
 | 
			
		||||
stack-checker.transforms
 | 
			
		||||
stack-checker.dependencies
 | 
			
		||||
stack-checker.recursive-state
 | 
			
		||||
stack-checker.row-polymorphism ;
 | 
			
		||||
QUALIFIED-WITH: generic.single.private gsp
 | 
			
		||||
USING: accessors alien alien.accessors alien.libraries
 | 
			
		||||
alien.private arrays assocs byte-arrays classes
 | 
			
		||||
classes.tuple.private combinators combinators.private
 | 
			
		||||
combinators.short-circuit compiler.units effects fry
 | 
			
		||||
generic.single.private io.files.private io.streams.c kernel
 | 
			
		||||
kernel.private locals locals.backend locals.types macros math
 | 
			
		||||
math.parser.private math.private memory memory.private
 | 
			
		||||
namespaces quotations quotations.private sequences
 | 
			
		||||
sequences.private slots.private stack-checker.alien
 | 
			
		||||
stack-checker.backend stack-checker.branches
 | 
			
		||||
stack-checker.dependencies stack-checker.errors
 | 
			
		||||
stack-checker.row-polymorphism stack-checker.state
 | 
			
		||||
stack-checker.transforms stack-checker.values
 | 
			
		||||
stack-checker.visitor strings strings.private system
 | 
			
		||||
threads.private tools.dispatch.private tools.memory.private
 | 
			
		||||
tools.profiler.sampling.private words words.private ;
 | 
			
		||||
IN: stack-checker.known-words
 | 
			
		||||
 | 
			
		||||
: infer-special ( word -- )
 | 
			
		||||
| 
						 | 
				
			
			@ -425,7 +415,7 @@ M: object infer-call* \ call bad-macro-input ;
 | 
			
		|||
\ innermost-frame-scan { callstack } { fixnum } define-primitive
 | 
			
		||||
\ jit-compile { quotation } { } define-primitive
 | 
			
		||||
\ leaf-signal-handler { } { } define-primitive
 | 
			
		||||
\ gsp:lookup-method { object array } { word } define-primitive
 | 
			
		||||
\ lookup-method { object array } { word } define-primitive
 | 
			
		||||
\ minor-gc { } { } define-primitive
 | 
			
		||||
\ modify-code-heap { array object object } { } define-primitive
 | 
			
		||||
\ nano-count { } { integer } define-primitive \ nano-count make-flushable
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,6 +1,7 @@
 | 
			
		|||
! Copyright (C) 2008, 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: accessors kernel namespaces stack-checker.recursive-state.tree ;
 | 
			
		||||
USING: accessors kernel namespaces
 | 
			
		||||
stack-checker.recursive-state.tree ;
 | 
			
		||||
IN: stack-checker.recursive-state
 | 
			
		||||
 | 
			
		||||
TUPLE: recursive-state quotations inline-words ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,12 +1,9 @@
 | 
			
		|||
! (c)2010 Joe Groff bsd license
 | 
			
		||||
USING: accessors arrays assocs combinators combinators.short-circuit
 | 
			
		||||
continuations effects fry kernel locals math math.order namespaces
 | 
			
		||||
quotations sequences splitting
 | 
			
		||||
stack-checker.backend
 | 
			
		||||
stack-checker.errors
 | 
			
		||||
stack-checker.state
 | 
			
		||||
stack-checker.values
 | 
			
		||||
stack-checker.visitor ;
 | 
			
		||||
! Copyright (C) 2010 Joe Groff
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license
 | 
			
		||||
USING: accessors arrays assocs combinators
 | 
			
		||||
combinators.short-circuit effects fry kernel locals math
 | 
			
		||||
math.order namespaces sequences stack-checker.errors
 | 
			
		||||
stack-checker.state stack-checker.values ;
 | 
			
		||||
IN: stack-checker.row-polymorphism
 | 
			
		||||
 | 
			
		||||
: with-inner-d ( quot -- inner-d )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -29,7 +29,8 @@ SYMBOL: literals
 | 
			
		|||
: commit-literals ( -- )
 | 
			
		||||
    literals get [ [ (push-literal) ] each ] [ delete-all ] bi ;
 | 
			
		||||
 | 
			
		||||
: current-stack-height ( -- n ) meta-d length input-count get - ;
 | 
			
		||||
: current-stack-height ( -- n )
 | 
			
		||||
    meta-d length input-count get - ;
 | 
			
		||||
 | 
			
		||||
: current-effect ( -- effect )
 | 
			
		||||
    input-count get "x" <array>
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,14 +1,11 @@
 | 
			
		|||
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: fry accessors arrays kernel kernel.private combinators.private
 | 
			
		||||
words sequences generic math math.order namespaces quotations
 | 
			
		||||
assocs combinators combinators.short-circuit classes.tuple
 | 
			
		||||
classes.tuple.private effects summary hashtables classes sets
 | 
			
		||||
definitions generic.standard slots.private continuations locals
 | 
			
		||||
sequences.private generalizations stack-checker.backend
 | 
			
		||||
stack-checker.state stack-checker.visitor stack-checker.errors
 | 
			
		||||
stack-checker.values stack-checker.recursive-state
 | 
			
		||||
stack-checker.dependencies ;
 | 
			
		||||
USING: accessors classes.tuple classes.tuple.private combinators
 | 
			
		||||
combinators.short-circuit continuations fry generic kernel
 | 
			
		||||
locals namespaces quotations sequences stack-checker.backend
 | 
			
		||||
stack-checker.dependencies stack-checker.errors
 | 
			
		||||
stack-checker.recursive-state stack-checker.values
 | 
			
		||||
stack-checker.visitor words ;
 | 
			
		||||
FROM: namespaces => set ;
 | 
			
		||||
IN: stack-checker.transforms
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,8 +1,7 @@
 | 
			
		|||
! Copyright (C) 2008, 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: accessors namespaces fry kernel assocs sequences
 | 
			
		||||
stack-checker.recursive-state stack-checker.errors
 | 
			
		||||
quotations ;
 | 
			
		||||
USING: accessors assocs fry kernel namespaces quotations
 | 
			
		||||
sequences stack-checker.errors stack-checker.recursive-state ;
 | 
			
		||||
IN: stack-checker.values
 | 
			
		||||
 | 
			
		||||
: <value> ( -- value ) \ <value> counter ;
 | 
			
		||||
| 
						 | 
				
			
			@ -12,10 +11,11 @@ SYMBOL: known-values
 | 
			
		|||
: init-known-values ( -- )
 | 
			
		||||
    H{ } clone known-values set ;
 | 
			
		||||
 | 
			
		||||
: known ( value -- known ) known-values get at ;
 | 
			
		||||
: known ( value -- known )
 | 
			
		||||
    known-values get at ;
 | 
			
		||||
 | 
			
		||||
: set-known ( known value -- )
 | 
			
		||||
    over [ known-values get set-at ] [ 2drop ] if ;
 | 
			
		||||
    '[ _ known-values get set-at ] when* ;
 | 
			
		||||
 | 
			
		||||
: make-known ( known -- value )
 | 
			
		||||
    <value> [ set-known ] keep ;
 | 
			
		||||
| 
						 | 
				
			
			@ -28,11 +28,13 @@ SYMBOL: known-values
 | 
			
		|||
 | 
			
		||||
GENERIC: (literal-value?) ( value -- ? )
 | 
			
		||||
 | 
			
		||||
: literal-value? ( value -- ? ) known (literal-value?) ;
 | 
			
		||||
: literal-value? ( value -- ? )
 | 
			
		||||
    known (literal-value?) ;
 | 
			
		||||
 | 
			
		||||
GENERIC: (input-value?) ( value -- ? )
 | 
			
		||||
 | 
			
		||||
: input-value? ( value -- ? ) known (input-value?) ;
 | 
			
		||||
: input-value? ( value -- ? )
 | 
			
		||||
    known (input-value?) ;
 | 
			
		||||
 | 
			
		||||
GENERIC: (literal) ( known -- literal )
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -63,11 +65,14 @@ C: <curried> curried
 | 
			
		|||
: >curried< ( curried -- obj quot )
 | 
			
		||||
    [ obj>> ] [ quot>> ] bi ; inline
 | 
			
		||||
 | 
			
		||||
M: curried (input-value?) >curried< [ input-value? ] either? ;
 | 
			
		||||
M: curried (input-value?)
 | 
			
		||||
    >curried< [ input-value? ] either? ;
 | 
			
		||||
 | 
			
		||||
M: curried (literal-value?) >curried< [ literal-value? ] both? ;
 | 
			
		||||
M: curried (literal-value?)
 | 
			
		||||
    >curried< [ literal-value? ] both? ;
 | 
			
		||||
 | 
			
		||||
M: curried (literal) >curried< [ curry ] curried/composed-literal ;
 | 
			
		||||
M: curried (literal)
 | 
			
		||||
    >curried< [ curry ] curried/composed-literal ;
 | 
			
		||||
 | 
			
		||||
TUPLE: composed quot1 quot2 ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -79,9 +84,11 @@ C: <composed> composed
 | 
			
		|||
M: composed (input-value?)
 | 
			
		||||
    [ quot1>> input-value? ] [ quot2>> input-value? ] bi or ;
 | 
			
		||||
 | 
			
		||||
M: composed (literal-value?) >composed< [ literal-value? ] both? ;
 | 
			
		||||
M: composed (literal-value?)
 | 
			
		||||
    >composed< [ literal-value? ] both? ;
 | 
			
		||||
 | 
			
		||||
M: composed (literal) >composed< [ compose ] curried/composed-literal ;
 | 
			
		||||
M: composed (literal)
 | 
			
		||||
    >composed< [ compose ] curried/composed-literal ;
 | 
			
		||||
 | 
			
		||||
SINGLETON: input-parameter
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -121,12 +128,16 @@ GENERIC: known>callable ( known -- quot )
 | 
			
		|||
    dup callable? [ drop [ @ ] ] unless ;
 | 
			
		||||
 | 
			
		||||
M: object known>callable drop \ _ ;
 | 
			
		||||
 | 
			
		||||
M: literal-tuple known>callable value>> ;
 | 
			
		||||
 | 
			
		||||
M: composed known>callable
 | 
			
		||||
    [ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi
 | 
			
		||||
    append ;
 | 
			
		||||
    [ quot1>> known known>callable ?@ ]
 | 
			
		||||
    [ quot2>> known known>callable ?@ ] bi append ;
 | 
			
		||||
 | 
			
		||||
M: curried known>callable
 | 
			
		||||
    [ quot>> known known>callable ] [ obj>> known known>callable ] bi
 | 
			
		||||
    prefix ;
 | 
			
		||||
    [ quot>> known known>callable ]
 | 
			
		||||
    [ obj>> known known>callable ] bi prefix ;
 | 
			
		||||
 | 
			
		||||
M: declared-effect known>callable
 | 
			
		||||
    known>> known>callable ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue