Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
6fd7a218
Commit
6fd7a218
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-03-21 13:31:43 by afrisch] Remove Compile2
Original author: afrisch Date: 2005-03-21 13:31:44+00:00
parent
0e13bca6
Changes
11
Expand all
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
6fd7a218
...
...
@@ -137,7 +137,7 @@ and compile_branches env tail (brs : Typed.branches) =
brs_tail
=
tail
;
brs_accept_chars
=
not
(
Types
.
Char
.
is_empty
brs
.
Typed
.
br_accept
);
brs_input
=
brs
.
Typed
.
br_typ
;
brs_compiled
=
None
;
brs_compiled2
=
None
brs_compiled
=
None
;
}
and
compile_branch
env
tail
br
=
...
...
compile/lambda.ml
View file @
6fd7a218
...
...
@@ -74,8 +74,6 @@ and branches = {
brs_accept_chars
:
bool
;
mutable
brs_compiled
:
(
Patterns
.
Compile
.
dispatcher
*
expr
Patterns
.
Compile
.
rhs
array
)
option
;
mutable
brs_compiled2
:
(
Patterns
.
Compile2
.
dispatcher
*
(
int
list
*
expr
)
option
array
)
option
;
}
let
rec
dump_expr
ppf
=
function
...
...
@@ -371,8 +369,7 @@ module Get = struct
let
accept_chars
=
bool
s
in
{
brs
=
brs
;
brs_tail
=
tail
;
brs_input
=
input
;
brs_accept_chars
=
accept_chars
;
brs_compiled
=
None
;
brs_compiled2
=
None
}
brs_compiled
=
None
}
let
code_item
s
=
match
bits
2
s
with
...
...
compile/lambda.mli
View file @
6fd7a218
...
...
@@ -48,8 +48,6 @@ and branches = {
brs_accept_chars
:
bool
;
mutable
brs_compiled
:
(
Patterns
.
Compile
.
dispatcher
*
expr
Patterns
.
Compile
.
rhs
array
)
option
;
mutable
brs_compiled2
:
(
Patterns
.
Compile2
.
dispatcher
*
(
int
list
*
expr
)
option
array
)
option
;
}
type
code_item
=
...
...
driver/cduce.ml
View file @
6fd7a218
...
...
@@ -223,21 +223,6 @@ let debug ppf tenv cenv = function
with
|
Exit
->
Format
.
fprintf
ppf
"Non constant@."
|
Not_found
->
Format
.
fprintf
ppf
"Empty@."
)
|
`Approx
(
p
,
t
)
->
Format
.
fprintf
ppf
"[DEBUG:approx]@."
;
let
t
=
Typer
.
typ
tenv
t
in
let
p
=
Typer
.
pat
tenv
p
in
Patterns
.
demo
ppf
(
Patterns
.
descr
p
)
(
Types
.
descr
t
);
(*
let (x,c) = Patterns.approx (Patterns.descr p) (Types.descr t) in
List.iter (fun x -> Format.fprintf ppf "%a=* " U.print (Id.value x)) x;
List.iter
(fun (x,c) ->
Format.fprintf ppf "%a=%a "
U.print (Id.value x)
Types.Print.print_const c
) c; *)
Format
.
fprintf
ppf
"@."
let
flush_ppf
ppf
=
Format
.
fprintf
ppf
"@."
...
...
parser/ast.ml
View file @
6fd7a218
...
...
@@ -24,7 +24,6 @@ and debug_directive =
|
`Subtype
of
ppat
*
ppat
|
`Explain
of
ppat
*
ppat
*
pexpr
|
`Single
of
ppat
|
`Approx
of
ppat
*
ppat
]
and
toplevel_directive
=
[
`Quit
...
...
parser/parser.ml
View file @
6fd7a218
...
...
@@ -213,7 +213,6 @@ EXTEND
|
IDENT
"subtype"
;
t1
=
pat
;
t2
=
pat
->
`Subtype
(
t1
,
t2
)
|
IDENT
"explain"
;
t0
=
pat
;
t
=
pat
;
e
=
expr
->
`Explain
(
t0
,
t
,
e
)
|
IDENT
"single"
;
t
=
pat
->
`Single
t
|
IDENT
"approx"
;
p
=
pat
;
t
=
pat
->
`Approx
(
p
,
t
)
]
];
...
...
runtime/eval.ml
View file @
6fd7a218
...
...
@@ -37,16 +37,6 @@ let dispatcher brs =
brs
.
brs_compiled
<-
Some
x
;
x
let
dispatcher2
brs
=
match
brs
.
brs_compiled2
with
|
Some
d
->
d
|
None
->
(* Format.fprintf Format.std_formatter "Start compilation...@."; *)
let
x
=
Patterns
.
Compile2
.
make_branches
brs
.
brs_input
brs
.
brs
in
(* Format.fprintf Format.std_formatter "Done.@."; *)
brs
.
brs_compiled2
<-
Some
x
;
x
let
stack
=
ref
(
Array
.
create
1024
Value
.
Absent
)
let
frame
=
ref
0
let
sp
=
ref
0
...
...
@@ -198,9 +188,7 @@ and eval_apply_tail_rec f arg =
and
eval_branches
env
brs
arg
=
eval_branches_old
env
brs
arg
and
eval_branches_old
env
brs
arg
=
and
eval_branches
env
brs
arg
=
let
(
disp
,
rhs
)
=
dispatcher
brs
in
let
(
code
,
bindings
)
=
Run_dispatch
.
run_dispatcher
disp
arg
in
match
rhs
.
(
code
)
with
...
...
@@ -217,24 +205,6 @@ and eval_branches_old env brs arg =
v
|
Patterns
.
Compile
.
Fail
->
Value
.
Absent
and
eval_branches_new
env
brs
arg
=
let
(
disp
,
rhs
)
=
dispatcher2
brs
in
let
(
code
,
bindings
)
=
Run_dispatch
.
run_dispatcher2
disp
arg
in
match
rhs
.
(
code
)
with
|
Some
(
bind
,
e
)
->
let
saved_sp
=
!
sp
in
List
.
iter
(
fun
i
->
push
(
if
(
i
==
-
1
)
then
arg
else
bindings
.
(
i
)))
bind
;
if
brs
.
brs_tail
then
eval
env
e
else
let
v
=
eval
env
e
in
sp
:=
saved_sp
;
v
|
None
->
Value
.
Absent
and
eval_ref
env
e
t
=
Value
.
mk_ref
(
Types
.
descr
t
)
(
eval
env
e
)
...
...
runtime/run_dispatch.ml
View file @
6fd7a218
...
...
@@ -335,9 +335,6 @@ let run_dispatcher d v =
cursor
:=
0
;
(
code
,!
buffer
)
let
old_dispatcher
=
run_dispatcher
(*
let rec check_overwrite_aux r i =
if i < 0 then true
...
...
@@ -352,255 +349,3 @@ let check_overwrite r2 r =
*)
(* New dispatcher *)
open
Patterns
.
Compile2
let
make_result_basic
v
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
>
0
then
(
ensure_room
n
;
let
buf
=
!
buffer
in
for
a
=
0
to
n
-
1
do
buf
.
(
!
cursor
)
<-
begin
match
Array
.
unsafe_get
r
a
with
|
SrcCapture
->
v
|
SrcCst
c
->
const
c
|
_
->
assert
false
end
;
incr
cursor
done
);
code
let
make_result_prod
v1
r1
v2
r2
v
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
>
0
then
(
ensure_room
n
;
let
buf
=
!
buffer
in
let
c
=
!
cursor
in
for
a
=
0
to
n
-
1
do
buf
.
(
c
+
a
)
<-
match
Array
.
unsafe_get
r
a
with
|
SrcCapture
->
v
|
SrcLeft
->
v1
|
SrcRight
->
v2
|
SrcCst
c
->
const
c
|
SrcFetchLeft
i
->
buf
.
(
r1
+
i
)
|
SrcFetchRight
i
->
buf
.
(
r2
+
i
)
|
SrcPair
(
l
,
r
)
->
Pair
(
(
match
l
with
|
SrcLeft
->
v1
|
SrcRight
->
v2
|
SrcFetchLeft
i
->
buf
.
(
r1
+
i
)
|
SrcFetchRight
i
->
buf
.
(
r2
+
i
)
|
_
->
assert
false
)
,
(
match
r
with
|
SrcLeft
->
v1
|
SrcRight
->
v2
|
SrcFetchLeft
i
->
buf
.
(
r1
+
i
)
|
SrcFetchRight
i
->
buf
.
(
r2
+
i
)
|
_
->
assert
false
))
|
_
->
assert
false
done
;
if
r1
!=
c
then
blit
buf
c
buf
r1
n
;
cursor
:=
r1
+
n
);
code
let
make_result_record
sp
v
(
code
,
r
)
=
let
n
=
Array
.
length
r
in
if
n
>
0
then
(
ensure_room
n
;
let
buf
=
!
buffer
in
let
c
=
!
cursor
in
for
a
=
0
to
n
-
1
do
buf
.
(
c
+
a
)
<-
match
Array
.
unsafe_get
r
a
with
|
SrcLocal
i
->
buf
.
(
sp
+
i
)
|
_
->
assert
false
done
;
if
sp
!=
c
then
blit
buf
c
buf
sp
n
;
cursor
:=
sp
+
n
);
code
let
rec
run_disp_basic
v
f
=
function
|
[(
_
,
r
)]
->
make_result_basic
v
r
|
(
t
,
r
)
::
rem
->
if
f
t
then
make_result_basic
v
r
else
run_disp_basic
v
f
rem
|
_
->
assert
false
let
count
=
ref
0
let
rec
run_dispatcher
d
v
=
(* Format.fprintf Format.std_formatter "Matching (%a)@." Value.print v; *)
(* Patterns.Compile.print_dispatcher Format.std_formatter d; *)
(* print_string "."; flush stdout; *)
(* incr count;
print_int !count;
print_string "X"; flush stdout;
if !count = 9685 then
Format.fprintf Format.std_formatter "Matching (%a)@\n with:@\n%a@."
Value.print v
Patterns.Compile2.print_dispatcher d;*)
let
res
=
match
actions
d
with
|
AResult
r
->
make_result_basic
v
r
|
AKind
k
->
run_disp_kind
k
v
in
(* print_string "Y"; flush stdout;*)
res
and
run_disp_kind
actions
v
=
match
v
with
|
Pair
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
prod
|
Xml
(
v1
,
v2
,
v3
)
|
XmlNs
(
v1
,
v2
,
v3
,_
)
->
run_disp_prod
v
v1
(
Pair
(
v2
,
v3
))
actions
.
xml
|
Record
r
->
run_disp_record
!
cursor
false
v
(
LabelMap
.
get
r
)
actions
.
record
|
String_latin1
(
i
,
j
,
s
,
q
)
->
run_disp_kind
actions
(
Value
.
normalize
v
)
(* run_disp_string_latin1 i j s q actions *)
|
String_utf8
(
i
,
j
,
s
,
q
)
as
v
->
run_disp_kind
actions
(
Value
.
normalize
v
)
(* run_disp_string_utf8 i j s q actions *)
|
Atom
a
->
make_result_basic
v
(
Atoms
.
get_map
a
actions
.
atoms
)
|
Char
c
->
make_result_basic
v
(
Chars
.
get_map
c
actions
.
chars
)
|
Integer
i
->
run_disp_basic
v
(
fun
t
->
Types
.
Int
.
has_int
t
i
)
actions
.
basic
|
Abstraction
(
None
,_
)
->
run_disp_basic
v
(
fun
t
->
failwith
"Run-time inspection of external abstraction"
)
actions
.
basic
|
Abstraction
(
Some
iface
,_
)
|
Abstraction2
(
_
,
iface
,_
)
->
run_disp_basic
v
(
fun
t
->
Types
.
Arrow
.
check_iface
iface
t
)
actions
.
basic
|
Abstract
(
abs
,_
)
->
run_disp_basic
v
(
fun
t
->
Types
.
Abstract
.
contains
abs
(
Types
.
get_abstract
t
))
actions
.
basic
|
Absent
->
run_disp_basic
v
(
fun
t
->
Types
.
Record
.
has_absent
t
)
actions
.
basic
|
Concat
(
_
,_
)
as
v
->
run_disp_kind
actions
(
Value
.
normalize
v
)
and
run_disp_prod
v
v1
v2
=
function
|
Impossible
->
assert
false
|
LeftRight
rdd
->
run_disp_prod'
v
v1
v2
rdd
|
RightLeft
rdd
->
run_disp_prod'
v
v2
v1
rdd
and
run_disp_prod'
v
v1
v2
=
function
|
Dispatch
(
d1
,
b1
)
->
let
r1
=
!
cursor
in
let
code1
=
run_dispatcher
d1
v1
in
run_disp_prod2
v1
r1
v
v2
b1
.
(
code1
)
|
TailCall
d1
->
run_dispatcher
d1
v1
|
Ignore
d2
->
run_disp_prod2
v1
!
cursor
v
v2
d2
and
run_disp_prod2
v1
r1
v
v2
=
function
|
Ignore
r
->
make_result_prod
v1
r1
v2
!
cursor
v
r
|
TailCall
d2
->
run_dispatcher
d2
v2
|
Dispatch
(
d2
,
b2
)
->
let
r2
=
!
cursor
in
let
code2
=
run_dispatcher
d2
v2
in
make_result_prod
v1
r1
v2
r2
v
b2
.
(
code2
)
and
do_pushes
v
vl
=
function
|
[]
->
()
|
PushConst
c
::
rem
->
push
(
const
c
);
do_pushes
v
vl
rem
|
PushField
::
rem
->
push
vl
;
do_pushes
v
vl
rem
|
PushCapture
::
rem
->
push
v
;
do_pushes
v
vl
rem
and
do_record_tr
sp
other
v
vl
fields
tr
=
let
(
pushes
,
ct
)
=
Lazy
.
force
tr
in
(* print_string "*"; flush stdout; *)
do_pushes
v
vl
pushes
;
run_disp_record
sp
other
v
fields
ct
and
run_disp_record
sp
other
v
fields
=
function
|
RecordLabel
(
l
,
d
,
cts
)
->
let
rec
aux
other
=
function
|
(
l1
,_
)
::
rem
when
l1
<
l
->
aux
true
rem
|
(
l1
,
vl
)
::
rem
when
l1
==
l
->
do_record_tr
sp
other
v
vl
rem
cts
.
(
run_dispatcher
d
vl
)
|
rem
->
do_record_tr
sp
other
v
Absent
rem
cts
.
(
run_dispatcher
d
Absent
)
in
aux
other
fields
|
RecordLabelSkip
(
l
,
pr
)
->
let
rec
aux
other
=
function
|
(
l1
,_
)
::
rem
when
l1
<
l
->
aux
true
rem
|
(
l1
,
vl
)
::
rem
when
l1
==
l
->
do_record_tr
sp
other
v
vl
rem
pr
|
rem
->
do_record_tr
sp
other
v
Absent
rem
pr
in
aux
other
fields
|
RecordResult
r
->
make_result_record
sp
v
r
|
RecordMore
(
nomore
,
more
)
->
let
other
=
other
||
(
fields
!=
[]
)
in
make_result_record
sp
v
(
if
other
then
more
else
nomore
)
|
RecordImpossible
->
assert
false
(*
and run_disp_string_latin1 i j s q actions =
if i == j then run_disp_kind actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
| Ignore d2 -> run_disp_string_latin1_2 !cursor i j s q d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i]) in
run_disp_string_latin1_2 r1 i j s q b1.(code1)
and run_disp_string_latin1_char d ch =
match actions d with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_latin1_2 r1 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_latin1 i j s q r1 0 r
| TailCall d2 -> run_disp_string_latin1_loop i j s q d2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_disp_string_latin1_loop i j s q d2 in
make_result_string_latin1 i j s q r1 r2 b2.(code2)
and run_disp_string_latin1_loop i j s q d =
match actions d with
| AIgnore r -> make_result_basic Absent r
| AKind k -> run_disp_string_latin1 (succ i) j s q k
and run_disp_string_utf8 i j s q actions =
if Utf8.equal_index i j then run_disp_kind actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i))
| Ignore d2 -> run_disp_string_utf8_2 !cursor i j s q d2
| Dispatch (d1,b1) ->
let r1 = !cursor in
let code1 = run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i)) in
run_disp_string_utf8_2 r1 i j s q b1.(code1)
and run_disp_string_utf8_char d ch =
match actions d with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_utf8_2 r1 i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_utf8 i j s q r1 0 r
| TailCall d2 -> run_disp_string_utf8_loop i j s q d2
| Dispatch (d2,b2) ->
let r2 = !cursor in
let code2 = run_disp_string_utf8_loop i j s q d2 in
make_result_string_utf8 i j s q r1 r2 b2.(code2)
and run_disp_string_utf8_loop i j s q d =
match actions d with
| AIgnore r -> make_result_basic Absent r
| AKind k -> run_disp_string_utf8 (Utf8.advance s i) j s q k
*)
let
run_dispatcher2
d
v
=
(* print_string "+"; flush stdout; *)
let
code
=
run_dispatcher
d
v
in
cursor
:=
0
;
(* print_string "-\n"; flush stdout; *)
(
code
,!
buffer
)
let
run_dispatcher
=
old_dispatcher
runtime/run_dispatch.mli
View file @
6fd7a218
...
...
@@ -2,4 +2,3 @@ open Value
val
run_dispatcher
:
Patterns
.
Compile
.
dispatcher
->
t
->
int
*
t
array
val
run_dispatcher2
:
Patterns
.
Compile2
.
dispatcher
->
t
->
int
*
t
array
types/patterns.ml
View file @
6fd7a218
This diff is collapsed.
Click to expand it.
types/patterns.mli
View file @
6fd7a218
...
...
@@ -85,62 +85,3 @@ module Compile: sig
val
debug_compile
:
Format
.
formatter
->
Types
.
Node
.
t
->
node
list
->
unit
end
module
Compile2
:
sig
type
dispatcher
type
source
=
|
SrcCapture
|
SrcLeft
|
SrcRight
|
SrcCst
of
Types
.
const
|
SrcPair
of
source
*
source
|
SrcFetchLeft
of
int
|
SrcFetchRight
of
int
|
SrcLocal
of
int
type
push
=
PushConst
of
Types
.
const
|
PushField
|
PushCapture
type
result
=
int
*
source
array
type
actions
=
|
AResult
of
result
|
AKind
of
actions_kind
and
actions_kind
=
{
basic
:
(
Types
.
t
*
result
)
list
;
atoms
:
result
Atoms
.
map
;
chars
:
result
Chars
.
map
;
prod
:
actions_prod
;
xml
:
actions_prod
;
record
:
actions_record
;
}
and
actions_record
=
|
RecordLabel
of
label
*
dispatcher
*
record_tr
array
|
RecordLabelSkip
of
label
*
record_tr
|
RecordResult
of
result
|
RecordMore
of
result
*
result
(* nomore, more *)
|
RecordImpossible
and
record_tr
=
(
push
list
*
actions_record
)
Lazy
.
t
and
actions_prod
=
|
LeftRight
of
result
dispatch
dispatch
|
RightLeft
of
result
dispatch
dispatch
|
Impossible
and
'
a
dispatch
=
|
Dispatch
of
dispatcher
*
'
a
array
|
TailCall
of
dispatcher
|
Ignore
of
'
a
val
actions
:
dispatcher
->
actions
val
make_branches
:
Types
.
t
->
(
node
*
'
a
)
list
->
dispatcher
*
(
int
list
*
'
a
)
option
array
val
print_dispatcher
:
Format
.
formatter
->
dispatcher
->
unit
end
val
approx
:
descr
->
Types
.
descr
->
id
list
*
(
id
*
Types
.
Const
.
t
)
list
val
demo
:
Format
.
formatter
->
descr
->
Types
.
descr
->
unit
val
demo_compile
:
Format
.
formatter
->
Types
.
descr
->
descr
list
->
unit
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment