compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.def-use ;
FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
+ FROM: namespaces => set ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
tri
] with-compilation-unit
-: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
-: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
-: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
-: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
+: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
'[
[ basic-block set ] [
[
compiler.cfg.loop-detection
compiler.cfg.renaming.functor
compiler.cfg.representations.preferred ;
+ FROM: namespaces => set ;
IN: compiler.cfg.representations
! Virtual register representation selection.
: record-renaming ( from to -- )
2array renaming-set get push needs-renaming? on ;
-:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
+:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
vreg rep-of :> preferred
preferred required eq?
[ vreg no-renaming ]
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg compiler.cfg.instructions ;
+ FROM: namespaces => set ;
IN: compiler.cfg.rpo
SYMBOL: visited
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
-: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
+: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
dupd '[ _ optimize-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
USING: accessors arrays assocs bit-arrays bit-sets fry
hashtables hints kernel locals math namespaces sequences sets
compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
+ FROM: namespaces => set ;
IN: compiler.cfg.ssa.construction.tdmsc
! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
SYMBOLS: visited merge-sets levels again? ;
: init-merge-sets ( cfg -- )
- post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
+ post-order dup length '[ _ <bit-set> ] H{ } map>assoc merge-sets set ;
: compute-levels ( cfg -- )
0 over entry>> associate [
: level ( bb -- n ) levels get at ; inline
- : set-bit ( bit-array n -- )
- [ t ] 2dip swap set-nth ;
-
: update-merge-set ( tmp to -- )
[ merge-sets get ] dip
'[
_
- [ merge-sets get at bit-set-union ]
- [ dupd number>> set-bit ]
+ [ merge-sets get at union ]
+ [ number>> over adjoin ]
bi
] change-at ;
tmp dom-parent to tmp walk
] [ lnode ] if ;
-: each-incoming-j-edge ( bb quot: ( from to -- ) -- )
+: each-incoming-j-edge ( ... bb quot: ( ... from to -- ... ) -- ... )
[ [ predecessors>> ] keep ] dip
'[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
- : visited? ( pair -- ? ) visited get key? ;
+ : visited? ( pair -- ? ) visited get in? ;
: consistent? ( snode lnode -- ? )
- [ merge-sets get at ] bi@ swap bit-set-subset? ;
+ [ merge-sets get at ] bi@ subset? ;
: (process-edge) ( from to -- )
f walk [
: process-edge ( from to -- )
2dup 2array dup visited? [ 3drop ] [
- visited get conjoin
+ visited get adjoin
(process-edge)
] if ;
[ process-edge ] each-incoming-j-edge ;
: compute-merge-set-step ( bfo -- )
- visited get clear-assoc
+ HS{ } clone visited set
[ process-block ] each ;
: compute-merge-set-loop ( cfg -- )
loop ;
: (merge-set) ( bbs -- flags rpo )
- merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
+ merge-sets get '[ _ at ] [ union ] map-reduce
cfg get reverse-post-order ; inline
- : filter-by ( flags seq -- seq' )
- [ drop ] selector [ 2each ] dip ;
-
- HINTS: filter-by { bit-array object } ;
-
PRIVATE>
: compute-merge-sets ( cfg -- )
needs-dominance
- H{ } clone visited set
+ HS{ } clone visited set
[ compute-levels ]
[ init-merge-sets ]
[ compute-merge-set-loop ]
tri ;
- : merge-set-each ( ... bbs quot: ( ... bb -- ... ) -- ... )
- [ (merge-set) ] dip '[
- swap _ [ drop ] if
- ] 2each ; inline
-
: merge-set ( bbs -- bbs' )
- (merge-set) filter-by ;
+ (merge-set) [ members ] dip nths ;
+
+ : merge-set-each ( bbs quot: ( bb -- ) -- )
+ [ merge-set ] dip each ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs arrays namespaces accessors sequences deques fry
search-deques dlists combinators.short-circuit make sets compiler.tree ;
+ FROM: namespaces => set ;
IN: compiler.tree.recursive
TUPLE: call-site tail? node label ;
recursive-nesting get pop*
] each ;
-: while-changing ( quot: ( -- ) -- )
+: while-changing ( ... quot: ( ... -- ... ) -- ... )
changed? off
[ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
inline recursive
math combinators namespaces urls.encoding xml.syntax xmode.code2html
xml.data arrays strings vectors xml.writer io.streams.string locals
unicode.categories ;
+ FROM: namespaces => set ;
IN: farkup
SYMBOL: relative-link-prefix
{ CHAR: % inline-code }
} at ;
-: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' )
+: or-simple-title ( ... url title/f quot: ( ... title -- ... title' ) -- ... url title' )
[ "" like dup simple-link-title ] if* ; inline
: parse-link ( string -- paragraph-list )
furnace.boilerplate\r
furnace.auth.providers\r
furnace.auth.providers.db ;\r
+FROM: assocs => change-at ;\r
+ FROM: namespaces => set ;\r
IN: furnace.auth\r
\r
SYMBOL: logged-in-user\r
namespaces sequences sequences.deep sets sorting splitting
strings unicode.categories values vocabs vocabs.loader words
words.symbol summary debugger io ;
+ FROM: sets => members ;
IN: help.lint.checks
ERROR: simple-lint-error message ;
first rest [ first ] map
] unless ;
+: extract-value-effects ( element -- seq )
+ \ $values swap elements dup empty? [
+ first rest [
+ \ $quotation swap elements dup empty? [ drop f ] [
+ first second
+ ] if
+ ] map
+ ] unless ;
+
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
- [ dup pair? [ first ] when effect>string ] map prune ;
+ [ dup pair? [ first ] when effect>string ] map members ;
+: effect-effects ( word -- seq )
+ stack-effect in>> [
+ dup pair?
+ [ second dup effect? [ effect>string ] [ drop f ] if ]
+ [ drop f ] if
+ ] map ;
+
: contains-funky-elements? ( element -- ? )
{
$shuffle
[ effect-values ]
[ extract-values ]
bi* sequence=
- ]
+ ]
} 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
+: check-value-effects ( word element -- )
+ [ effect-effects ]
+ [ extract-value-effects ]
+ bi* [ 2dup and [ = ] [ 2drop t ] if ] 2all?
+ [ "$quotation documentation in $values don't match stack effect" simple-lint-error ]
+ unless ;
+
: check-nulls ( element -- )
\ $values swap elements
null swap deep-member?
: check-see-also ( element -- )
\ $see-also swap elements [
- rest dup prune [ length ] bi@ assert=
+ rest all-unique? t assert=
] each ;
: vocab-exists? ( name -- ? )
USING: kernel sequences regexp.transition-tables fry assocs
accessors locals math sorting arrays sets hashtables regexp.dfa
combinators.short-circuit regexp.classes ;
+FROM: assocs => change-at ;
IN: regexp.minimize
: table>state-numbers ( table -- assoc )
{
[ drop <= ]
[ transitions>> '[ _ at keys ] bi@ set= ]
- [ final-states>> '[ _ key? ] bi@ = ]
+ [ final-states>> '[ _ in? ] bi@ = ]
} 3&& ;
:: initialize-partitions ( transition-table -- partitions )
<reversed>
>hashtable ;
-:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
+:: (while-changes) ( ..a obj quot: ( ..a obj -- ..b obj' ) comp: ( ..b obj' -- ..a key ) old-key -- ..a obj )
obj quot call :> new-obj
new-obj comp call :> new-key
new-key old-key =
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 sets hints macros stack-checker.state
+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 ;
+FROM: sequences.private => from-end ;
+ FROM: namespaces => set ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
[ #introduce, ]
tri ;
+: update-inner-d ( new -- )
+ inner-d-index get min inner-d-index set ;
+
: pop-d ( -- obj )
- meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
+ meta-d
+ [ <value> dup 1array introduce-values ]
+ [ pop meta-d length update-inner-d ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
[ introduce-values ] [ meta-d push-all ] bi
meta-d push-all
- ] when swap tail* ;
+ ] when
+ swap from-end [ tail ] [ update-inner-d ] bi ;
: shorten-by ( n seq -- )
[ length swap - ] keep shorten ; inline
+: shorten-d ( n -- )
+ meta-d shorten-by meta-d length update-inner-d ;
+
: consume-d ( n -- seq )
- [ ensure-d ] [ meta-d shorten-by ] bi ;
+ [ ensure-d ] [ shorten-d ] bi ;
: output-d ( values -- ) meta-d push-all ;
: infer-r> ( n -- )
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
-: consume/produce ( effect quot: ( inputs outputs -- ) -- )
+: consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
'[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
[ terminated?>> [ terminate ] when ]
bi ; inline
current-effect
stack-visitor get
] with-scope ; inline
+
+: (infer) ( quot -- effect )
+ [ infer-quot-here ] with-infer drop ;
+
+: ?quotation-effect ( in -- effect/f )
+ dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
+
+:: declare-effect-d ( word effect variables branches n -- )
+ meta-d length :> d-length
+ n d-length < [
+ d-length 1 - n - :> n'
+ n' meta-d nth :> value
+ value known :> known
+ known word effect variables branches <declared-effect> :> known'
+ known' value set-known
+ known' branches push
+ ] [ word unknown-macro-input ] if ;
+
+:: declare-input-effects ( word -- )
+ H{ } clone :> variables
+ V{ } clone :> branches
+ word stack-effect in>> <reversed> [| in n |
+ in ?quotation-effect [| effect |
+ word effect variables branches n declare-effect-d
+ ] when*
+ ] each-index ;
+
combinators.short-circuit classes.tuple alien.c-types ;
FROM: classes.tuple.private => tuple-layout ;
FROM: assocs => change-at ;
+ FROM: namespaces => set ;
IN: stack-checker.dependencies
! Words that the current quotation depends on
[ \ depends-on-final add-conditional-dependency ] bi ;
M: depends-on-final satisfied?
- class>> final-class? ;
+ class>> { [ class? ] [ final-class? ] } 1&& ;
: init-dependencies ( -- )
H{ } clone dependencies set
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state
stack-checker.dependencies ;
+ FROM: namespaces => set ;
IN: stack-checker.transforms
: call-transformer ( stack quot -- newquot )
:: ((apply-transform)) ( quot values stack rstate -- )
rstate recursive-state [ stack quot call-transformer ] with-variable
- values [ length meta-d shorten-by ] [ #drop, ] bi
+ values [ length shorten-d ] [ #drop, ] bi
rstate infer-quot ;
: literal-values? ( values -- ? ) [ literal-value? ] all? ;
: contiguous-range? ( keys -- ? )
dup [ fixnum? ] all? [
dup all-unique? [
- [ prune length ]
+ [ length ]
[ [ supremum ] [ infimum ] bi - ]
bi - 1 =
] [ drop f ] if
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
-: to-fixed-point ( object quot: ( object(n) -- object(n+1) ) -- object(n) )
+: to-fixed-point ( ... object quot: ( ... object(n) -- ... object(n+1) ) -- ... object(n) )
[ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive
-! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs benchmark bootstrap.stage2 compiler.errors
-source-files.errors generic help.html help.lint io.directories
-io.encodings.utf8 io.files kernel mason.common math namespaces
-prettyprint sequences sets sorting tools.test tools.time
-words system io tools.errors vocabs.hierarchy vocabs.errors
-vocabs.refresh locals ;
+USING: accessors assocs benchmark bootstrap.stage2
+compiler.errors source-files.errors generic help.html help.lint
+io.directories io.encodings.utf8 io.files kernel mason.common
+math namespaces prettyprint sequences sets sorting tools.test
+tools.time words system io tools.errors vocabs vocabs.files
+vocabs.hierarchy vocabs.errors vocabs.refresh locals
+source-files compiler.units ;
IN: mason.test
: do-load ( -- )
:: do-step ( errors summary-file details-file -- )
errors
[ error-type +linkage-error+ eq? not ] filter
- [ file>> ] map prune natural-sort summary-file to-file
+ [ file>> ] map members natural-sort summary-file to-file
errors details-file utf8 [ errors. ] with-file-writer ;
: do-tests ( -- )
test-all-errors-file
do-step ;
+: cleanup-tests ( -- )
+ ! Free up some code heap space
+ [
+ vocabs [ vocab-tests [ forget-source ] each ] each
+ ] with-compilation-unit ;
+
: do-help-lint ( -- )
help-lint-all lint-failures get values
help-lint-vocabs-file
"" to-refresh drop 2dup [ empty? not ] either?
[
"Boot image is out of date. Changed vocabs:" print
- append prune [ print ] each
+ members [ print ] each
flush
1 exit
] [ 2drop ] if ;
[ do-load ] benchmark load-time-file to-file
[ generate-help ] benchmark html-help-time-file to-file
[ do-tests ] benchmark test-time-file to-file
+ cleanup-tests
[ do-help-lint ] benchmark help-lint-time-file to-file
[ do-benchmarks ] benchmark benchmark-time-file to-file
do-compile-errors
projects / factor.git / commitdiff