steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

more parser cleanups; stack inference cleanups

cvs
Slava Pestov 2005-01-14 19:56:19 +00:00
parent 3eccfa495e
commit 651bdb4709
13 changed files with 110 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
library/compiler/linearizer.factor
View File

@ -34,6 +34,8 @@ USE: namespaces
USE: words
USE: strings
USE: errors
USE: prettyprint
USE: kernel-internals
! The linear IR is close to assembly language. It also resembles
! Forth code in some sense. It exists so that pattern matching
@ -51,7 +53,7 @@ SYMBOL: #jump ( tail-call )
SYMBOL: #jump-label ( tail-call )
SYMBOL: #return-to ( push addr on C stack )
! #dispatch is linearized as #dispatch followed by a #target
! dispatch is linearized as dispatch followed by a #target
! for each dispatch table entry. The linearizer ensures the
! correct number of #targets is emitted.
SYMBOL: #target ( part of jump table )
@ -127,8 +129,7 @@ SYMBOL: #target ( part of jump table )
: linearize-ifte ( param -- )
#! The parameter is a list of two lists, each one a dataflow
#! IR.
uncons car
<label> [
2unlist <label> [
#jump-t swons ,
(linearize) ( false branch )
<label> dup #jump-label swons ,
@ -136,14 +137,14 @@ SYMBOL: #target ( part of jump table )
swap (linearize) ( true branch )
label, ( branch target of false branch end ) ;
#ifte [
\ ifte [
[ node-param get ] bind linearize-ifte
] "linearizer" set-word-property
: dispatch-head ( vtable -- end label/code )
#! Output the jump table insn and return a list of
#! label/branch pairs.
[ #dispatch ] ,
[ dispatch ] ,
<label> ( end label ) swap
[ <label> dup #target swons , cons ] map ;
@ -163,7 +164,7 @@ SYMBOL: #target ( part of jump table )
#! take in case the top of stack has that type.
dup check-dispatch dispatch-head dupd dispatch-body label, ;
#dispatch [
\ dispatch [
[ node-param get ] bind linearize-dispatch
] "linearizer" set-word-property

17
library/compiler/optimizer.factor
View File

@ -32,6 +32,7 @@ USE: kernel
USE: inference
USE: words
USE: prettyprint
USE: kernel-internals
! The optimizer transforms dataflow IR to dataflow IR. Currently
! it removes literals that are eventually dropped, and never
@ -149,11 +150,11 @@ USE: prettyprint
: branches-call-label? ( label list -- ? )
[ dupd calls-label? ] some? nip ;
#ifte [
\ ifte [
[ node-param get ] bind branches-call-label?
] "calls-label" set-word-property
#dispatch [
\ dispatch [
[ node-param get ] bind branches-call-label?
] "calls-label" set-word-property
@ -169,13 +170,13 @@ USE: prettyprint
] extend ,
] "kill-node" set-word-property
#ifte [ scan-branches ] "scan-literal" set-word-property
#ifte [ can-kill-branches? ] "can-kill" set-word-property
#ifte [ kill-branches ] "kill-node" set-word-property
\ ifte [ scan-branches ] "scan-literal" set-word-property
\ ifte [ can-kill-branches? ] "can-kill" set-word-property
\ ifte [ kill-branches ] "kill-node" set-word-property
#dispatch [ scan-branches ] "scan-literal" set-word-property
#dispatch [ can-kill-branches? ] "can-kill" set-word-property
#dispatch [ kill-branches ] "kill-node" set-word-property
\ dispatch [ scan-branches ] "scan-literal" set-word-property
\ dispatch [ can-kill-branches? ] "can-kill" set-word-property
\ dispatch [ kill-branches ] "kill-node" set-word-property
! Don't care about inputs to recursive combinator calls
#call-label [ 2drop t ] "can-kill" set-word-property

2
library/compiler/x86/generator.factor
View File

@ -84,7 +84,7 @@ USE: words
#return [ drop RET ] "generator" set-word-property
#dispatch [
\ dispatch [
#! Compile a piece of code that jumps to an offset in a
#! jump table indexed by the fixnum at the top of the stack.
#! The jump table must immediately follow this macro.

2
library/generic/predicate.factor
View File

@ -77,7 +77,7 @@ predicate [
pick "superclass" word-property "predicate" word-property
[ \ dup , append, , [ drop f ] , \ ifte , ] make-list
define-compound
predicate define-class ;
predicate "metaclass" set-word-property ;
: PREDICATE: ( -- class predicate definition )
#! Followed by a superclass name, then a class name.

6
library/inference/branches.factor
View File

@ -222,7 +222,7 @@ SYMBOL: cloned
: dynamic-ifte ( true false -- )
#! If branch taken is computed, infer along both paths and
#! unify.
2list >r 1 meta-d get vector-tail* #ifte r>
2list >r 1 meta-d get vector-tail* \ ifte r>
pop-d [
dup \ general-t cons ,
\ f cons ,
@ -246,15 +246,15 @@ SYMBOL: cloned
dup value-recursion swap literal-value vector>list
[ over <literal> ] map nip ;
USE: kernel-internals
: infer-dispatch ( -- )
#! Infer effects for all branches, unify.
[ object vector ] ensure-d
dataflow-drop, pop-d vtable>list
>r 1 meta-d get vector-tail* #dispatch r>
>r 1 meta-d get vector-tail* \ dispatch r>
pop-d ( n ) num-types [ dupd cons ] project nip zip
infer-branches ;
USE: kernel-internals
\ dispatch [ infer-dispatch ] "infer" set-word-property
\ dispatch [ [ fixnum vector ] [ ] ]
"infer-effect" set-word-property

3
library/inference/dataflow.factor
View File

@ -49,9 +49,6 @@ SYMBOL: #call ( non-tail call )
SYMBOL: #call-label
SYMBOL: #push ( literal )
SYMBOL: #ifte
SYMBOL: #dispatch
! This is purely a marker for values we retain after a
! conditional. It does not generate code, but merely alerts the
! dataflow optimizer to the fact these values must be retained.

16
library/lists.factor
View File

@ -172,21 +172,7 @@ M: cons = ( obj cons -- ? )
] ifte
] ifte ;
: cons-hashcode ( cons count -- hash )
dup 0 number= [
2drop 0
] [
over cons? [
1 - >r uncons r> tuck
cons-hashcode >r
cons-hashcode r>
bitxor
] [
drop hashcode
] ifte
] ifte ;
M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
M: cons hashcode ( cons -- hash ) car hashcode ;
: project ( n quot -- list )
#! Execute the quotation n times, passing the loop counter

19
library/syntax/parse-syntax.factor
View File

@ -2,7 +2,7 @@
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
! Copyright (C) 2004, 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
@ -117,21 +117,20 @@ USE: unparser
scan dup "use" cons@ "in" set ; parsing
! Char literal
: CHAR: ( -- ) next-word-ch parse-ch swons ; parsing
: CHAR: ( -- ) 0 scan next-char drop swons ; parsing
! String literal
: parse-string ( -- )
next-ch dup CHAR: " = [
drop
: parse-string ( n str -- n )
2dup str-nth CHAR: " = [
drop 1 +
] [
parse-ch , parse-string
[ next-char swap , ] keep parse-string
] ifte ;
: "
#! Note the ugly hack to carry the new value of 'pos' from
#! the make-string scope up to the original scope.
[ parse-string "col" get ] make-string
swap "col" set swons ; parsing
"col" [
"line" get [ parse-string ] make-string swap
] change swons ; parsing
! Comments
: (

94
library/syntax/parser.factor
View File

@ -2,7 +2,7 @@
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
! Copyright (C) 2004, 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
@ -48,22 +48,6 @@ USE: unparser
: parsing? ( word -- ? )
dup word? [ "parsing" word-property ] [ drop f ] ifte ;
: end? ( -- ? )
"col" get "line" get str-length >= ;
: (with-parser) ( quot -- )
end? [ drop ] [ [ call ] keep (with-parser) ] ifte ;
: with-parser ( text quot -- )
#! Keep calling the quotation until we reach the end of the
#! input.
swap "line" set 0 "col" set
(with-parser)
"line" off "col" off ;
: ch ( -- ch ) "col" get "line" get str-nth ;
: advance ( -- ) "col" [ 1 + ] change ;
: skip ( n line quot -- n )
#! Find the next character that satisfies the quotation,
#! which should have stack effect ( ch -- ? ).
@ -80,9 +64,6 @@ USE: unparser
: skip-blank ( n line -- n )
[ blank? not ] skip ;
: skip-word ( n line -- n )
[ blank? ] skip ;
: denotation? ( ch -- ? )
#! Hard-coded for now. Make this customizable later.
#! A 'denotation' is a character that is treated as its
@ -93,37 +74,35 @@ USE: unparser
#! Will call the parsing word ".
"\"" str-contains? ;
: (scan) ( n line -- start end )
dup >r skip-blank dup r>
2dup str-length < [
2dup str-nth denotation? [
drop 1 +
] [
skip-word
] ifte
: skip-word ( n line -- n )
2dup str-nth denotation? [
drop 1 +
] [
drop
[ blank? ] skip
] ifte ;
: (scan) ( n line -- start end )
[ skip-blank dup ] keep
2dup str-length < [ skip-word ] [ drop ] ifte ;
: scan ( -- token )
"col" get "line" get dup >r (scan) dup "col" set
2dup = [
r> 3drop f
] [
r> substring
] ifte ;
2dup = [ r> 3drop f ] [ r> substring ] ifte ;
: scan-word ( -- obj )
scan dup [
dup "use" get search [ str>number ] ?unless
] when ;
: parse-loop ( -- )
scan-word [
dup parsing? [ execute ] [ swons ] ifte parse-loop
] when* ;
: (parse) ( str -- )
[
scan-word [
dup parsing? [ execute ] [ swons ] ifte
] when*
] with-parser ;
"line" set 0 "col" set
parse-loop
"line" off "col" off ;
: parse ( str -- code )
#! Parse the string into a parse tree that can be executed.
@ -151,12 +130,6 @@ USE: unparser
#! the parser is already line-tokenized.
(until-eol) (until) ;
: next-ch ( -- ch )
end? [ "Unexpected EOF" throw ] [ ch advance ] ifte ;
: next-word-ch ( -- ch )
"col" get "line" get skip-blank "col" set next-ch ;
: CREATE ( -- word )
scan "in" get create dup set-word
dup f "documentation" set-word-property
@ -165,15 +138,7 @@ USE: unparser
dup "col" get "col" set-word-property
dup "file" get "file" set-word-property ;
! \x
: unicode-escape>ch ( -- esc )
#! Read \u....
next-ch digit> 16 *
next-ch digit> + 16 *
next-ch digit> + 16 *
next-ch digit> + ;
: ascii-escape>ch ( ch -- esc )
: escape ( ch -- esc )
[
[[ CHAR: e CHAR: \e ]]
[[ CHAR: n CHAR: \n ]]
@ -184,20 +149,21 @@ USE: unparser
[[ CHAR: 0 CHAR: \0 ]]
[[ CHAR: \\ CHAR: \\ ]]
[[ CHAR: \" CHAR: \" ]]
] assoc ;
] assoc dup [ "Bad escape" throw ] unless ;
: escape ( ch -- esc )
dup CHAR: u = [
drop unicode-escape>ch
: next-escape ( n str -- ch n )
2dup str-nth CHAR: u = [
swap 1 + dup 4 + [ rot substring hex> ] keep
] [
ascii-escape>ch
over 1 + >r str-nth escape r>
] ifte ;
: parse-escape ( -- )
next-ch escape dup [ drop "Bad escape" throw ] unless ;
: parse-ch ( ch -- ch )
dup CHAR: \\ = [ drop parse-escape ] when ;
: next-char ( n str -- ch n )
2dup str-nth CHAR: \\ = [
>r 1 + r> next-escape
] [
over 1 + >r str-nth r>
] ifte ;
: doc-comment-here? ( parsed -- ? )
not "in-definition" get and ;

10
library/test/compiler/linearizer.factor Normal file
View File

@ -0,0 +1,10 @@
IN: scratchpad
USE: test
USE: kernel
USE: compiler
USE: inference
USE: words
: foo [ drop ] each-word ;
[ ] [ \ foo word-parameter dataflow linearize drop ] unit-test

8
library/test/dataflow.factor
View File

@ -41,7 +41,7 @@ USE: generic
! ] unit-test
[ t ] [
#ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean
\ ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean
] unit-test
: dataflow-consume-d-len ( object -- n )
@ -55,7 +55,7 @@ USE: generic
[ t ] [ [ 2 ] dataflow car dataflow-produce-d-len 1 = ] unit-test
: dataflow-ifte-node-consume-d ( list -- node )
#ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ;
\ ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ;
[ t ] [
[ [ swap ] [ nip "hi" ] ifte ] dataflow
@ -64,7 +64,7 @@ USE: generic
! [ t ] [
! [ { [ drop ] [ undefined-method ] [ drop ] [ undefined-method ] } generic ] dataflow
! #dispatch swap dataflow-contains-op? car [
! \ dispatch swap dataflow-contains-op? car [
! node-param get [
! [ [ node-param get \ undefined-method = ] bind ] some?
! ] some?
@ -94,6 +94,6 @@ SYMBOL: #test
! Somebody (cough) got the order of ifte nodes wrong.
[ t ] [
#ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car
\ ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car
[ node-param get ] bind car car [ node-param get ] bind 1 =
] unit-test

61
library/test/parser.factor
View File

@ -7,52 +7,59 @@ USE: kernel
USE: generic
USE: words
[ CHAR: a 1 ]
[ 0 "abcd" next-char ] unit-test
[ CHAR: \s 6 ]
[ 1 "\\u0020hello" next-escape ] unit-test
[ CHAR: \n 2 ]
[ 1 "\\nhello" next-escape ] unit-test
[ CHAR: \s 6 ]
[ 0 "\\u0020hello" next-char ] unit-test
[ [ 1 [ 2 [ 3 ] 4 ] 5 ] ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" ]
[ parse ]
test-word
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" parse ]
unit-test
[ [ t t f f ] ]
[ "t t f f" ]
[ parse ]
test-word
[ "t t f f" parse ]
unit-test
[ [ "hello world" ] ]
[ "\"hello world\"" ]
[ parse ]
test-word
[ "\"hello world\"" parse ]
unit-test
[ [ "\n\r\t\\" ] ]
[ "\"\\n\\r\\t\\\\\"" ]
[ parse ]
test-word
[ "\"\\n\\r\\t\\\\\"" parse ]
unit-test
[ "hello world" ]
[ "IN: scratchpad : hello \"hello world\" ;" ]
[ parse call "USE: scratchpad hello" eval ]
test-word
[
"IN: scratchpad : hello \"hello world\" ;"
parse call "USE: scratchpad hello" eval
] unit-test
[ ]
[ "! This is a comment, people." ]
[ parse call ]
test-word
[ "! This is a comment, people." parse call ]
unit-test
[ ]
[ "( This is a comment, people. )" ]
[ parse call ]
test-word
[ "( This is a comment, people. )" parse call ]
unit-test
! Test escapes
[ [ " " ] ]
[ "\"\\u0020\"" ]
[ parse ]
test-word
[ "\"\\u0020\"" parse ]
unit-test
[ [ "'" ] ]
[ "\"\\u0027\"" ]
[ parse ]
test-word
[ "\"\\u0027\"" parse ]
unit-test
[ "\\u123" parse ] unit-test-fails
! Test improper lists

1
library/test/test.factor
View File

@ -123,6 +123,7 @@ USE: unparser
"compiler/ifte"
"compiler/generic"
"compiler/bail-out"
"compiler/linearizer"
] [
test
] each