[m-dev.] for review - new stuff for the extras directory.
Thomas Conway
conway at cs.mu.OZ.AU
Mon Feb 28 12:31:51 AEDT 2000
Hi
Here's the simple concurrency stuff for the extras. It doesn't discuss the
semantics at all - zs and I need to rework the paper for that. When we've
done so, we'll include a link.
--
Thomas Conway )O+ Every sword has two edges.
Mercurian <conway at cs.mu.oz.au>
Add a new directory of concurrency stuff to the extras.
extras/concurrency/README:
A short readme file describing the contents of the directory.
extras/concurrency/spawn.m:
extras/concurrency/semaphore.m:
extras/concurrency/stream.m:
extras/concurrency/global.m:
The modules providing the basic facilities for doing concurrent
programming.
extras/concurrency/philo.m:
An implementation of the classic dining philosophers program.
extras/concurrency/midimon.m:
A MIDI data stream monitor.
extras/concurrency/midi.m:
A concurrent midi stream parser/writer.
-------------- next part --------------
depend : philo.depend
default_target : philo
-------------- next part --------------
This directory contains stuff for doing coroutining with deterministic goals.
See the two example programs:
philo - the dining philosophers example
midimon - a midi data monitor that concurrently reads the bytestream,
parses the midi messages, and writes out the results.
-------------- next part --------------
%---------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% Main author: conway
% Stability: medium.
%
% This module provides a simple mechanism for storing values associated
% with keys in the global io__state. It is quite like library/store.m,
% except that it implicitly stores things in the io__state rather than in a
% separate store.
%
%---------------------------------------------------------------------------%
:- module global.
:- interface.
:- import_module io.
:- type global(T).
% new(Thing, Key, IO0, IO) binds `Key' to an abstract key refering
% to the object `Thing'.
:- pred global__new(T, global(T), io__state, io__state).
:- mode global__new(in, out, di, uo) is det.
% get(Key, Thing, IO0, IO) binds `Thing' to the object currently
% associated with `Key'.
:- pred global__get(global(T), T, io__state, io__state).
:- mode global__get(in, out, di, uo) is det.
% set(Key, Thing, IO0, IO) changes the value associated with `Key'
% to be `Thing'.
:- pred global__set(global(T), T, io__state, io__state).
:- mode global__set(in, in, di, uo) is det.
%---------------------------------------------------------------------------%
:- implementation.
:- import_module std_util.
:- type global(T)
---> global(c_pointer).
:- pragma c_code(global__new(Thing::in, Glob::out, IO0::di, IO::uo),
will_not_call_mercury, "{
Word *tmp;
incr_hp((Word) tmp, 1);
*tmp = Thing;
Glob = (Word) tmp;
IO = IO0;
}").
:- pragma c_code(global__get(Glob::in, Thing::out, IO0::di, IO::uo),
will_not_call_mercury, "{
Thing = *(Word *) Glob;
IO = IO0;
}").
:- pragma c_code(global__set(Glob::in, Thing::in, IO0::di, IO::uo),
will_not_call_mercury, "{
*((Word *) Glob) = Thing;
IO = IO0;
}").
-------------- next part --------------
%---------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% Main author: conway
%
% This module provides routines for concurrently reading and writing MIDI
% streams. MIDI stands for "Musical Instrument Digital Interface" and is a
% hardware and software protocol for electronic instruments to talk to each
% other.
%
%------------------------------------------------------------------------------%
:- module midi.
:- interface.
:- import_module stream.
:- import_module io, list.
% For information about the meaning
:- type message
---> off(channel, note, velocity) % note off
; on(channel, note, velocity) % note on
; kp(channel, note, pressure) % polyphonic aftertouch
; cc(channel, parameter, value) % controller change
; pc(channel, program) % program change
; cp(channel, pressure) % monophonic aftertouch
; pw(channel, pitch_value) % pitch wheel change
; mm(channel, modes) % mode message
; sys(system) % system message
; rt(realtime) % realtime message
.
:- type channel == int. % 0 - 15.
:- type note == int. % 0 - 127
:- type velocity == int. % 0 - 127
:- type pressure == int. % 0 - 127
:- type parameter == int. % 0 - 127
:- type value == int. % 0 - 127
:- type program == int. % 0 - 127
:- type pitch_value == int. % 0 - (1 << 14 - 1) biased from 0x2000
:- type modes
---> local(onoff)
; ano
; omni(onoff)
; mono(byte)
; poly
.
:- type onoff
---> off
; on
.
:- type system
---> sysex(list(byte))
; pos(int)
; sel(byte)
; tune
.
:- type realtime
---> clk
; start
; cont
; stop
; sense
; reset
.
:- type byte == int.
% Reads from a concurrent stream of bytes and puts its outputs
% on to a concurrent stream of midi messages.
:- pred read_midi(stream(byte), stream(message), io__state, io__state).
:- mode read_midi(in, in, di, uo) is det.
% Reads from a concurrent stream of messages, and puts the messages
% on to a concurrent stream of bytes.
:- pred write_midi(stream(message), stream(byte), io__state, io__state).
:- mode write_midi(in, in, di, uo) is det.
%------------------------------------------------------------------------------%
:- implementation.
:- import_module bool, int, require.
:- type hex
---> x0 ; x1 ; x2 ; x3
; x4 ; x5 ; x6 ; x7
; x8 ; x9 ; xA ; xB
; xC ; xD ; xE ; xF
.
:- type status
---> none
; status(kind, channel).
:- type kind
---> one(onebyte)
; two(twobyte)
.
:- type onebyte
---> pc
; cp
.
:- type twobyte
---> off
; on
; kp
; cc
; pw
.
%------------------------------------------------------------------------------%
read_midi(Ins, Outs) -->
byte0(none, Ins, Outs).
:- pred byte0(status, stream(byte), stream(message),
io__state, io__state).
:- mode byte0(in, in, in, di, uo) is det.
byte0(Status, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
end(Outs)
;
{ Res0 = error(Err) },
error(Outs, Err)
;
{ Res0 = ok(Byte) },
{ byte2hex(Byte, MSN, LSN) },
byte0a(MSN, LSN, Status, Ins, Outs)
).
:- pred byte0a(hex, hex, status, stream(byte), stream(message),
io__state, io__state).
:- mode byte0a(in, in, in, in, in, di, uo) is det.
byte0a(x0, LSN, Status, Ins, Outs) -->
{ hex2byte(x0, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x1, LSN, Status, Ins, Outs) -->
{ hex2byte(x1, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x2, LSN, Status, Ins, Outs) -->
{ hex2byte(x2, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x3, LSN, Status, Ins, Outs) -->
{ hex2byte(x3, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x4, LSN, Status, Ins, Outs) -->
{ hex2byte(x4, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x5, LSN, Status, Ins, Outs) -->
{ hex2byte(x5, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x6, LSN, Status, Ins, Outs) -->
{ hex2byte(x6, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x7, LSN, Status, Ins, Outs) -->
{ hex2byte(x7, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte0a(x8, LSN, _Status, Ins, Outs) -->
{ nibble2hex(Chan, LSN) },
{ Status = status(two(off), Chan) },
byte1(Status, Ins, Outs).
byte0a(x9, LSN, _Status, Ins, Outs) -->
{ nibble2hex(Chan, LSN) },
{ Status = status(two(on), Chan) },
byte1(Status, Ins, Outs).
byte0a(xA, LSN, _Status, Ins, Outs) -->
{ nibble2hex(Chan, LSN) },
{ Status = status(two(kp), Chan) },
byte1(Status, Ins, Outs).
byte0a(xB, LSN, _Status, Ins, Outs) -->
{ nibble2hex(Chan, LSN) },
{ Status = status(two(cc), Chan) },
byte1(Status, Ins, Outs).
byte0a(xC, LSN, _Status, Ins, Outs) -->
{ nibble2hex(Chan, LSN) },
{ Status = status(one(pc), Chan) },
byte1(Status, Ins, Outs).
byte0a(xD, LSN, _Status, Ins, Outs) -->
{ nibble2hex(Chan, LSN) },
{ Status = status(one(cp), Chan) },
byte1(Status, Ins, Outs).
byte0a(xE, LSN, _Status, Ins, Outs) -->
{ nibble2hex(Chan, LSN) },
{ Status = status(two(pw), Chan) },
byte1(Status, Ins, Outs).
byte0a(xF, x0, Status, Ins, Outs) -->
sysex0(Status, Ins, Outs).
byte0a(xF, x1, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte0a(xF, x2, Status, Ins, Outs) -->
pos0(Status, Ins, Outs).
byte0a(xF, x3, Status, Ins, Outs) -->
sel0(Status, Ins, Outs).
byte0a(xF, x4, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte0a(xF, x5, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte0a(xF, x6, Status, Ins, Outs) -->
put(Outs, sys(tune)),
byte0(Status, Ins, Outs).
byte0a(xF, x7, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte (byte0)").
byte0a(xF, x8, Status, Ins, Outs) -->
put(Outs, rt(clk)),
byte0(Status, Ins, Outs).
byte0a(xF, x9, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte0a(xF, xA, Status, Ins, Outs) -->
put(Outs, rt(start)),
byte0(Status, Ins, Outs).
byte0a(xF, xB, Status, Ins, Outs) -->
put(Outs, rt(cont)),
byte0(Status, Ins, Outs).
byte0a(xF, xC, Status, Ins, Outs) -->
put(Outs, rt(stop)),
byte0(Status, Ins, Outs).
byte0a(xF, xD, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte0a(xF, xE, Status, Ins, Outs) -->
put(Outs, rt(sense)),
byte0(Status, Ins, Outs).
byte0a(xF, xF, Status, Ins, Outs) -->
put(Outs, rt(reset)),
byte0(Status, Ins, Outs).
:- pred byte1(status, stream(byte), stream(message),
io__state, io__state).
:- mode byte1(in, in, in, di, uo) is det.
byte1(Status, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
error(Outs, "unexpected end of input")
;
{ Res0 = error(Err) },
error(Outs, Err)
;
{ Res0 = ok(Byte) },
{ byte2hex(Byte, MSN, LSN) },
byte1a(MSN, LSN, Status, Ins, Outs)
).
:- pred byte1a(hex, hex, status, stream(byte), stream(message),
io__state, io__state).
:- mode byte1a(in, in, in, in, in, di, uo) is det.
byte1a(x0, LSN, Status, Ins, Outs) -->
{ hex2byte(x0, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x1, LSN, Status, Ins, Outs) -->
{ hex2byte(x1, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x2, LSN, Status, Ins, Outs) -->
{ hex2byte(x2, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x3, LSN, Status, Ins, Outs) -->
{ hex2byte(x3, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x4, LSN, Status, Ins, Outs) -->
{ hex2byte(x4, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x5, LSN, Status, Ins, Outs) -->
{ hex2byte(x5, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x6, LSN, Status, Ins, Outs) -->
{ hex2byte(x6, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x7, LSN, Status, Ins, Outs) -->
{ hex2byte(x7, LSN, Byte) },
byte1b(Status, Byte, Ins, Outs).
byte1a(x8, _LSN, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte1a(x9, _LSN, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte1a(xA, _LSN, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte1a(xB, _LSN, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte1a(xC, _LSN, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte1a(xD, _LSN, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte1a(xE, _LSN, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte1a(xF, x0, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte1a(xF, x1, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte1a(xF, x2, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte1a(xF, x3, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte1a(xF, x4, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte1a(xF, x5, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte1a(xF, x6, Status, Ins, Outs) -->
put(Outs, sys(tune)),
byte1(Status, Ins, Outs).
byte1a(xF, x7, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte1a(xF, x8, Status, Ins, Outs) -->
put(Outs, rt(clk)),
byte1(Status, Ins, Outs).
byte1a(xF, x9, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte1a(xF, xA, Status, Ins, Outs) -->
put(Outs, rt(start)),
byte1(Status, Ins, Outs).
byte1a(xF, xB, Status, Ins, Outs) -->
put(Outs, rt(cont)),
byte1(Status, Ins, Outs).
byte1a(xF, xC, Status, Ins, Outs) -->
put(Outs, rt(stop)),
byte1(Status, Ins, Outs).
byte1a(xF, xD, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte1a(xF, xE, Status, Ins, Outs) -->
put(Outs, rt(sense)),
byte1(Status, Ins, Outs).
byte1a(xF, xF, Status, Ins, Outs) -->
put(Outs, rt(reset)),
byte1(Status, Ins, Outs).
:- pred byte1b(status, byte, stream(byte), stream(message),
io__state, io__state).
:- mode byte1b(in, in, in, in, di, uo) is det.
byte1b(none, _Byte, Ins, Outs) -->
byte0(none, Ins, Outs).
byte1b(status(one(Kind), Chan), Byte, Ins, Outs) -->
(
{ Kind = pc },
{ Msg = pc(Chan, Byte) }
;
{ Kind = cp },
{ Msg = cp(Chan, Byte) }
),
put(Outs, Msg),
byte0(status(one(Kind), Chan), Ins, Outs).
byte1b(status(two(Kind), Chan), Byte1, Ins, Outs) -->
byte2(status(two(Kind), Chan), Byte1, Ins, Outs).
:- pred byte2(status, byte, stream(byte), stream(message),
io__state, io__state).
:- mode byte2(in, in, in, in, di, uo) is det.
byte2(Status, Byte1, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
error(Outs, "unexpected end of input")
;
{ Res0 = error(Err) },
error(Outs, Err)
;
{ Res0 = ok(Byte2) },
{ byte2hex(Byte2, MSN2, LSN2) },
byte2a(MSN2, LSN2, Byte1, Status, Ins, Outs)
).
:- pred byte2a(hex, hex, byte, status, stream(byte), stream(message),
io__state, io__state).
:- mode byte2a(in, in, in, in, in, in, di, uo) is det.
byte2a(x0, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x0, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x1, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x1, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x2, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x2, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x3, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x3, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x4, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x4, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x5, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x5, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x6, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x6, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x7, LSN, Byte1, Status, Ins, Outs) -->
{ hex2byte(x7, LSN, Byte2) },
byte2b(Status, Byte1, Byte2, Ins, Outs).
byte2a(x8, _LSN, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte2a(x9, _LSN, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte2a(xA, _LSN, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte2a(xB, _LSN, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte2a(xC, _LSN, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte2a(xD, _LSN, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte2a(xE, _LSN, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected status byte").
byte2a(xF, x0, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte2a(xF, x1, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte2a(xF, x2, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte2a(xF, x3, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte2a(xF, x4, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte2a(xF, x5, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte2a(xF, x6, Byte1, Status, Ins, Outs) -->
put(Outs, sys(tune)),
byte2(Status, Byte1, Ins, Outs).
byte2a(xF, x7, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "unexpected system byte").
byte2a(xF, x8, Byte1, Status, Ins, Outs) -->
put(Outs, rt(clk)),
byte2(Status, Byte1, Ins, Outs).
byte2a(xF, x9, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte2a(xF, xA, Byte1, Status, Ins, Outs) -->
put(Outs, rt(start)),
byte2(Status, Byte1, Ins, Outs).
byte2a(xF, xB, Byte1, Status, Ins, Outs) -->
put(Outs, rt(cont)),
byte2(Status, Byte1, Ins, Outs).
byte2a(xF, xC, Byte1, Status, Ins, Outs) -->
put(Outs, rt(stop)),
byte2(Status, Byte1, Ins, Outs).
byte2a(xF, xD, _Byte1, _Status, _Ins, Outs) -->
error(Outs, "undefined system byte").
byte2a(xF, xE, Byte1, Status, Ins, Outs) -->
put(Outs, rt(sense)),
byte2(Status, Byte1, Ins, Outs).
byte2a(xF, xF, Byte1, Status, Ins, Outs) -->
put(Outs, rt(reset)),
byte2(Status, Byte1, Ins, Outs).
:- pred byte2b(status, byte, byte, stream(byte), stream(message),
io__state, io__state).
:- mode byte2b(in, in, in, in, in, di, uo) is det.
byte2b(none, _Byte1, _Byte2, Ins, Outs) -->
byte0(none, Ins, Outs).
byte2b(status(one(_), _Chan), _Byte1, _Byte2, _Ins, Outs) -->
error(Outs, "internal error").
byte2b(status(two(Kind), Chan), Byte1, Byte2, Ins, Outs) -->
(
{ Kind = off },
{ Msg = off(Chan, Byte1, Byte2) }
;
{ Kind = on },
{ Msg = on(Chan, Byte1, Byte2) }
;
{ Kind = kp },
{ Msg = kp(Chan, Byte1, Byte2) }
;
{ Kind = cc },
( {
Byte1 = 122,
( Byte2 = 0 ->
OnOrOff = off
;
OnOrOff = on
),
Msg0 = mm(Chan, local(OnOrOff))
;
Byte1 = 123,
Msg0 = mm(Chan, ano)
;
Byte1 = 124,
Msg0 = mm(Chan, omni(off))
;
Byte1 = 125,
Msg0 = mm(Chan, omni(on))
;
Byte1 = 126,
Msg0 = mm(Chan, mono(Byte2))
;
Byte1 = 127,
Msg0 = mm(Chan, poly)
} ->
{ Msg = Msg0 }
;
{ Msg = cc(Chan, Byte1, Byte2) }
)
;
{ Kind = pw },
{ Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7) },
{ Msg = pw(Chan, Val) }
),
put(Outs, Msg),
byte0(status(two(Kind), Chan), Ins, Outs).
:- pred sysex0(status, stream(byte), stream(message), io__state, io__state).
:- mode sysex0(in, in, in, di, uo) is det.
sysex0(Status, Ins, Outs) -->
sysex1([], Status, Ins, Outs).
:- pred sysex1(list(byte), status, stream(byte), stream(message),
io__state, io__state).
:- mode sysex1(in, in, in, in, di, uo) is det.
sysex1(Bytes0, Status, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
error(Outs, "unexpected end of input")
;
{ Res0 = error(Err) },
error(Outs, Err)
;
{ Res0 = ok(Byte) },
( { Byte >= 0, Byte =< 127 } ->
sysex1([Byte|Bytes0], Status, Ins, Outs)
;
{ reverse(Bytes0, Bytes) },
put(Outs, sys(sysex(Bytes))),
( { Byte = 0xF7 } ->
byte0(Status, Ins, Outs)
;
{ byte2hex(Byte, MSN, LSN) },
byte0a(MSN, LSN, Status, Ins, Outs)
)
)
).
:- pred pos0(status, stream(byte), stream(message), io__state, io__state).
:- mode pos0(in, in, in, di, uo) is det.
pos0(Status, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
error(Outs, "unexpected end of input")
;
{ Res0 = error(Err) },
error(Outs, Err)
;
{ Res0 = ok(Byte) },
pos1(Byte, Status, Ins, Outs)
).
:- pred pos1(byte, status, stream(byte), stream(message), io__state, io__state).
:- mode pos1(in, in, in, in, di, uo) is det.
pos1(Byte1, Status, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
error(Outs, "unexpected end of input")
;
{ Res0 = error(Err) },
error(Outs, Err)
;
{ Res0 = ok(Byte2) },
{ Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7) },
put(Outs, sys(pos(Val))),
byte0(Status, Ins, Outs)
).
:- pred sel0(status, stream(byte), stream(message), io__state, io__state).
:- mode sel0(in, in, in, di, uo) is det.
sel0(Status, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
error(Outs, "unexpected end of input")
;
{ Res0 = error(Err) },
error(Outs, Err)
;
{ Res0 = ok(Byte) },
put(Outs, sys(sel(Byte))),
byte0(Status, Ins, Outs)
).
%------------------------------------------------------------------------------%
%------------------------------------------------------------------------------%
write_midi(Ins, Outs) -->
write_midi(none, Ins, Outs).
:- pred write_midi(status, stream(message), stream(byte), io__state, io__state).
:- mode write_midi(in, in, in, di, uo) is det.
write_midi(Status, Ins, Outs) -->
get(Ins, Res0),
(
{ Res0 = end },
end(Outs)
;
{ Res0 = error(Msg) },
error(Outs, Msg)
;
{ Res0 = ok(Msg) },
write_midi(Msg, Status, Ins, Outs)
).
:- pred write_midi(message, status, stream(message), stream(byte),
io__state, io__state).
:- mode write_midi(in, in, in, in, di, uo) is det.
write_midi(off(Chan, Note, Vel), Status0, Ins, Outs) -->
{ Status1 = status(two(off), Chan) },
write_two(Status0, Status1, Note, Vel, Ins, Outs).
write_midi(on(Chan, Note, Vel), Status0, Ins, Outs) -->
{ Status1 = status(two(on), Chan) },
write_two(Status0, Status1, Note, Vel, Ins, Outs).
write_midi(kp(Chan, Note, Press), Status0, Ins, Outs) -->
{ Status1 = status(two(kp), Chan) },
write_two(Status0, Status1, Note, Press, Ins, Outs).
write_midi(cc(Chan, Ctrl, Val), Status0, Ins, Outs) -->
{ Status1 = status(two(cc), Chan) },
write_two(Status0, Status1, Ctrl, Val, Ins, Outs).
write_midi(pc(Chan, Prog), Status0, Ins, Outs) -->
{ Status1 = status(one(pc), Chan) },
write_one(Status0, Status1, Prog, Ins, Outs).
write_midi(cp(Chan, Press), Status0, Ins, Outs) -->
{ Status1 = status(one(cp), Chan) },
write_one(Status0, Status1, Press, Ins, Outs).
write_midi(pw(Chan, Val), Status0, Ins, Outs) -->
{ Status1 = status(two(pw), Chan) },
{ Byte1 = Val /\ 0x7F },
{ Byte2 = (Val >> 7) /\ 0x7F },
write_two(Status0, Status1, Byte1, Byte2, Ins, Outs).
write_midi(mm(Chan, Mode), Status0, Ins, Outs) -->
{ Status1 = status(two(cc), Chan) },
(
{ Mode = local(off) },
{ Byte1 = 122, Byte2 = 0 }
;
{ Mode = local(on) },
{ Byte1 = 122, Byte2 = 127 }
;
{ Mode = ano },
{ Byte1 = 123, Byte2 = 0 }
;
{ Mode = omni(off) },
{ Byte1 = 124, Byte2 = 0 }
;
{ Mode = omni(on) },
{ Byte1 = 125, Byte2 = 0 }
;
{ Mode = mono(N) },
{ Byte1 = 126, Byte2 = N /\ 0x7F }
;
{ Mode = poly },
{ Byte1 = 127, Byte2 = 0 }
),
write_two(Status0, Status1, Byte1, Byte2, Ins, Outs).
write_midi(sys(sysex(Bytes)), Status, Ins, Outs) -->
put(Outs, 0xF0),
foldl((pred(Byte::in, di, uo) is det -->
( { Byte >= 0, Byte =< 127 } ->
put(Outs, Byte)
;
error(Outs, "sysex data byte out of range")
)
), Bytes),
put(Outs, 0xF7),
write_midi(Status, Ins, Outs).
write_midi(sys(pos(Pos)), Status, Ins, Outs) -->
put(Outs, 0xF2),
{ Byte1 = Pos /\ 0x7F },
{ Byte2 = (Pos >> 7) /\ 0x7F },
put(Outs, Byte1),
put(Outs, Byte2),
write_midi(Status, Ins, Outs).
write_midi(sys(sel(Sel)), Status, Ins, Outs) -->
put(Outs, 0xF3),
put(Outs, Sel),
write_midi(Status, Ins, Outs).
write_midi(sys(tune), Status, Ins, Outs) -->
put(Outs, 0xF6),
write_midi(Status, Ins, Outs).
write_midi(rt(clk), Status, Ins, Outs) -->
put(Outs, 0xF8),
write_midi(Status, Ins, Outs).
write_midi(rt(start), Status, Ins, Outs) -->
put(Outs, 0xFA),
write_midi(Status, Ins, Outs).
write_midi(rt(cont), Status, Ins, Outs) -->
put(Outs, 0xFB),
write_midi(Status, Ins, Outs).
write_midi(rt(stop), Status, Ins, Outs) -->
put(Outs, 0xFC),
write_midi(Status, Ins, Outs).
write_midi(rt(sense), Status, Ins, Outs) -->
put(Outs, 0xFE),
write_midi(Status, Ins, Outs).
write_midi(rt(reset), Status, Ins, Outs) -->
put(Outs, 0xFF),
write_midi(Status, Ins, Outs).
:- pred write_one(status, status, byte, stream(message), stream(byte),
io__state, io__state).
:- mode write_one(in, in, in, in, in, di, uo) is det.
write_one(Status0, Status1, Byte1, Ins, Outs) -->
( { Status0 = Status1 } ->
{ Status = Status0 }
;
{ Status = Status1 },
( { status(Status, Byte) } ->
put(Outs, Byte)
;
error(Outs, "invalid channel")
)
),
( { Byte1 >= 0, Byte1 =< 127 } ->
put(Outs, Byte1)
;
error(Outs, "invalid data byte")
),
write_midi(Status, Ins, Outs).
:- pred write_two(status, status, byte, byte, stream(message), stream(byte),
io__state, io__state).
:- mode write_two(in, in, in, in, in, in, di, uo) is det.
write_two(Status0, Status1, Byte1, Byte2, Ins, Outs) -->
( { Status0 = Status1 } ->
{ Status = Status0 }
;
{ Status = Status1 },
( { status(Status, Byte) } ->
put(Outs, Byte)
;
error(Outs, "invalid channel")
)
),
( { Byte1 >= 0, Byte1 =< 127 } ->
put(Outs, Byte1)
;
error(Outs, "invalid data byte")
),
( { Byte2 >= 0, Byte2 =< 127 } ->
put(Outs, Byte2)
;
error(Outs, "invalid data byte")
),
write_midi(Status, Ins, Outs).
:- pred status(status, byte).
:- mode status(in, out) is semidet.
status(none, _) :-
error("status: no status").
status(status(Kind, Chan), Byte) :-
Chan >= 0, Chan =< 15,
(
Kind = two(off), Nib = 0x80
; Kind = two(on), Nib = 0x90
; Kind = two(kp), Nib = 0xA0
; Kind = two(cc), Nib = 0xB0
; Kind = one(pc), Nib = 0xC0
; Kind = one(cp), Nib = 0xD0
; Kind = two(pw), Nib = 0xE0
),
Byte = Nib \/ Chan.
%------------------------------------------------------------------------------%
%------------------------------------------------------------------------------%
:- pred byte2hex(int, hex, hex).
:- mode byte2hex(in, out, out) is det.
byte2hex(Byte, MSN, LSN) :-
(
nibble2hex(Byte /\ 0xF, LSN0),
nibble2hex((Byte >> 4) /\ 0xF, MSN0)
->
LSN = LSN0,
MSN = MSN0
;
error("byte2hex: conversion failed!")
).
:- pred hex2byte(hex, hex, int).
:- mode hex2byte(in, in, out) is det.
hex2byte(MSN, LSN, Byte) :-
nibble2hex(A, MSN),
nibble2hex(B, LSN),
Byte = B \/ (A << 4).
:- pred nibble2hex(int, hex).
:- mode nibble2hex(in, out) is semidet.
:- mode nibble2hex(out, in) is det.
nibble2hex(0x0, x0).
nibble2hex(0x1, x1).
nibble2hex(0x2, x2).
nibble2hex(0x3, x3).
nibble2hex(0x4, x4).
nibble2hex(0x5, x5).
nibble2hex(0x6, x6).
nibble2hex(0x7, x7).
nibble2hex(0x8, x8).
nibble2hex(0x9, x9).
nibble2hex(0xA, xA).
nibble2hex(0xB, xB).
nibble2hex(0xC, xC).
nibble2hex(0xD, xD).
nibble2hex(0xE, xE).
nibble2hex(0xF, xF).
-------------- next part --------------
:- module midimon.
:- interface.
:- import_module io.
:- pred main(io:state, io:state).
:- mode main(di, uo) is cc_multi.
:- implementation.
:- import_module midi.
:- import_module global, stream, spawn.
:- import_module bool, getopt, int, list, require, std_util, string.
main -->
io__command_line_arguments(Args0),
{ process_options(
option_ops(short_option, long_option, option_defaults),
Args0, _Args, MOpts) },
(
{ MOpts = ok(Opts) },
{ lookup_bool_option(Opts, help, Help) },
( { Help = yes } ->
help
;
{ lookup_maybe_string_option(Opts, input, MInfile) },
open_input(MInfile, InFileOpened),
(
{ InFileOpened = yes },
new(Bytes0),
new(Messages),
spawn((pred(di, uo) is cc_multi -->
read_midi(Bytes0, Messages)
)),
spawn((pred(di, uo) is cc_multi -->
print_messages(Messages)
)),
read_input(Bytes0)
;
{ InFileOpened = no }
)
)
;
{ MOpts = error(Msg) },
stderr_stream(StdErr),
format(StdErr, "%s\n", [s(Msg)])
).
:- pred open_input(maybe(string), bool, io__state, io__state).
:- mode open_input(in, out, di, uo) is det.
open_input(no, Opened) -->
see_binary("/dev/midi", Res),
(
{ Res = ok },
{ Opened = yes }
;
{ Res = error(Err) },
{ error_message(Err, Msg) },
stderr_stream(StdErr),
format(StdErr, "error opening `/dev/midi': %s\n", [s(Msg)]),
{ Opened = no }
).
open_input(yes(FileName), Opened) -->
( { FileName = "-" } ->
% use stdin
{ Opened = yes }
;
see_binary(FileName, Res),
(
{ Res = ok },
{ Opened = yes }
;
{ Res = error(Err) },
{ error_message(Err, Msg) },
stderr_stream(StdErr),
format(StdErr, "error opening `%s': %s\n",
[s(FileName), s(Msg)]),
{ Opened = no }
)
).
:- pred read_input(stream(byte), io__state, io__state).
:- mode read_input(in, di, uo) is det.
read_input(Stream) -->
io__read_byte(Res0),
(
{ Res0 = eof },
end(Stream)
;
{ Res0 = error(Err) },
{ io__error_message(Err, Msg) },
error(Stream, Msg)
;
{ Res0 = ok(Byte) },
put(Stream, Byte),
read_input(Stream)
).
:- pred print_messages(stream(message), io__state, io__state).
:- mode print_messages(in, di, uo) is det.
print_messages(Stream) -->
get(Stream, Res0),
(
{ Res0 = ok(Msg) },
write(Msg), write_string(".\n"),
print_messages(Stream)
;
{ Res0 = end }
;
{ Res0 = error(Msg) },
write_string(Msg), nl
).
:- type option_table == option_table(option).
:- type maybe_option_table == maybe_option_table(option).
% The master list of options.
:- type option
---> help
; input
.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- pred long_option(string::in, option::out) is semidet.
long_option("help", help).
long_option("input-file", input).
:- pred short_option(character::in, option::out) is semidet.
short_option('h', help).
short_option('i', input).
:- pred option_defaults(option :: out, option_data :: out) is nondet.
option_defaults(Opt, Data) :-
semidet_succeed,
option_defaults0(Opt, Data).
:- pred option_defaults0(option :: out, option_data :: out) is multi.
option_defaults0(help, bool(no)).
option_defaults0(input, maybe_string(no)).
:- pred help(io__state, io__state).
:- mode help(di, uo) is det.
help -->
write_strings([
"usage: midimon [-h] [--input-file|-i <filename>]\n",
" -h print this help message.\n",
" --input-file|-i <file> read from <file> (default is /dev/midi).\n"
]).
%-----------------------------------------------------------------------------%
-------------- next part --------------
%---------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% Main author: conway
%
% The classic "Dining Philosophers" problem, to show how
%
%---------------------------------------------------------------------------%
:- module philo.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is cc_multi.
:- implementation.
:- import_module spawn, global, semaphore.
:- import_module bool, list, require, string.
:- type forks
---> forks(bool, bool, bool, bool, bool).
:- type philosopher
---> plato
; aristotle
; descartes
; russell
; sartre
.
main -->
new(Lock), signal(Lock),
new(forks(yes, yes, yes, yes, yes), ForkGlob),
spawn(philosopher(plato, Lock, ForkGlob)),
spawn(philosopher(aristotle, Lock, ForkGlob)),
spawn(philosopher(descartes, Lock, ForkGlob)),
spawn(philosopher(russell, Lock, ForkGlob)),
philosopher(sartre, Lock, ForkGlob).
:- pred philosopher(philosopher, semaphore, global(forks),
io__state, io__state).
:- mode philosopher(in, in, in, di, uo) is cc_multi.
philosopher(Who, Lock, ForkGlob) -->
{ name(Who, Name) },
io__format("%s is thinking.\n", [s(Name)]),
wait(Lock),
get(ForkGlob, Forks0),
( { forks(Who, Forks0, Forks1) } ->
set(ForkGlob, Forks1),
signal(Lock),
io__format("%s is eating.\n", [s(Name)]),
wait(Lock),
get(ForkGlob, Forks2),
( { forks(Who, Forks3, Forks2) } ->
set(ForkGlob, Forks3),
signal(Lock)
;
{ error("all forked up") }
)
;
% Our 2 forks were not available
signal(Lock)
),
philosopher(Who, Lock, ForkGlob).
:- pred forks(philosopher, forks, forks).
:- mode forks(in, in, out) is semidet.
:- mode forks(in, out, in) is semidet.
forks(plato, forks(yes, yes, C, D, E), forks(no, no, C, D, E)).
forks(aristotle, forks(A, yes, yes, D, E), forks(A, no, no, D, E)).
forks(descartes, forks(A, B, yes, yes, E), forks(A, B, no, no, E)).
forks(russell, forks(A, B, C, yes, yes), forks(A, B, C, no, no)).
forks(sartre, forks(yes, B, C, D, yes), forks(no, B, C, D, no)).
:- pred name(philosopher, string).
:- mode name(in, out) is det.
name(plato , "Plato").
name(aristotle , "Aristotle").
name(descartes , "Descartes").
name(russell , "Russell").
name(sartre , "Sartre").
-------------- next part --------------
%---------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% Main author: conway
% Stability: medium.
%
% This module implements a simple semaphore data type for allowing
% coroutines to synchronise with one another.
%
%---------------------------------------------------------------------------%
:- module semaphore.
:- interface.
:- import_module bool, io.
:- type semaphore.
% new(Sem, IO0, IO) creates a new semaphore `Sem' with its counter
% initialized to 0.
:- pred semaphore__new(semaphore, io__state, io__state).
:- mode semaphore__new(out, di, uo) is det.
% wait(Sem, IO0, IO) blocks until the counter associated with `Sem'
% becomes greater than 0, whereupon it wakes, decrements the
% counter and returns.
:- pred semaphore__wait(semaphore, io__state, io__state).
:- mode semaphore__wait(in, di, uo) is det.
% try_wait(Sem, Succ, IO0, IO) is the same as wait/3, except that
% instead of blocking, it binds `Succ' to a boolean indicating
% whether the call succeeded in obtaining the semaphore or not.
:- pred semaphore__try_wait(semaphore, bool, io__state, io__state).
:- mode semaphore__try_wait(in, out, di, uo) is det.
% signal(Sem, IO0, IO) increments the counter associated with `Sem'
% and if the resulting counter has a value greater than 0, it wakes
% one or more coroutines that are waiting on this semaphore (if
% any).
:- pred semaphore__signal(semaphore, io__state, io__state).
:- mode semaphore__signal(in, di, uo) is det.
%---------------------------------------------------------------------------%
:- implementation.
:- import_module std_util.
:- type semaphore == c_pointer.
:- pragma c_header_code("
#include <stdio.h>
typedef struct ME_SEMAPHORE_STRUCT {
int count;
MR_Context *suspended;
#ifdef MR_THREAD_SAFE
MR_Lock lock;
#endif
} ME_Semaphore;
").
:- pragma c_code(semaphore__new(Semaphore::out, IO0::di, IO::uo),
will_not_call_mercury, "{
ME_Semaphore *sem;
incr_hp((Word *) sem, round_up(sizeof(ME_Semaphore), sizeof(Word)));
sem->count = 0;
sem->suspended = NULL;
#ifdef MR_THREAD_SAFE
pthread_mutex_init(&(sem->lock), MR_MUTEX_ATTR);
#endif
Semaphore = (Word) sem;
IO = IO0;
}").
% because semaphore__signal has a local label, we may get
% C compilation errors if inlining leads to multiple copies
% of this code.
:- pragma no_inline(semaphore__signal/3).
:- pragma c_code(semaphore__signal(Semaphore::in, IO0::di, IO::uo),
will_not_call_mercury, "{
ME_Semaphore *sem;
MR_Context *ctxt;
sem = (ME_Semaphore *) Semaphore;
MR_LOCK(&(sem->lock), ""semaphore__signal"");
if (sem->count >= 0 && sem->suspended != NULL) {
ctxt = sem->suspended;
sem->suspended = ctxt->next;
MR_UNLOCK(&(sem->lock), ""semaphore__signal"");
schedule(ctxt);
/* yield() */
save_context(MR_ENGINE(this_context));
MR_ENGINE(this_context)->resume = &&signal_skip_to_the_end_1;
schedule(MR_ENGINE(this_context));
runnext();
signal_skip_to_the_end_1:
} else {
sem->count++;
MR_UNLOCK(&(sem->lock), ""semaphore__signal"");
/* yield() */
save_context(MR_ENGINE(this_context));
MR_ENGINE(this_context)->resume = &&signal_skip_to_the_end_2;
schedule(MR_ENGINE(this_context));
runnext();
signal_skip_to_the_end_2:
}
IO = IO0;
}").
% because semaphore__wait has a local label, we may get
% C compilation errors if inlining leads to multiple copies
% of this code.
:- pragma no_inline(semaphore__wait/3).
:- pragma c_code(semaphore__wait(Semaphore::in, IO0::di, IO::uo),
will_not_call_mercury, "{
ME_Semaphore *sem;
MR_Context *ctxt;
sem = (ME_Semaphore *) Semaphore;
MR_LOCK(&(sem->lock), ""semaphore__wait"");
if (sem->count > 0) {
sem->count--;
MR_UNLOCK(&(sem->lock), ""semaphore__wait"");
} else {
save_context(MR_ENGINE(this_context));
MR_ENGINE(this_context)->resume = &&wait_skip_to_the_end;
MR_ENGINE(this_context)->next = sem->suspended;
sem->suspended = MR_ENGINE(this_context);
MR_UNLOCK(&(sem->lock), ""semaphore__wait"");
runnext();
wait_skip_to_the_end:
}
IO = IO0;
}").
semaphore__try_wait(Sem, Res) -->
semaphore__try_wait0(Sem, Res0),
( { Res0 = 0 } ->
{ Res = yes }
;
{ Res = no }
).
:- pred semaphore__try_wait0(semaphore, int, io__state, io__state).
:- mode semaphore__try_wait0(in, out, di, uo) is det.
:- pragma c_code(semaphore__try_wait0(Semaphore::in, Res::out, IO0::di, IO::uo),
will_not_call_mercury, "{
ME_Semaphore *sem;
MR_Context *ctxt;
sem = (ME_Semaphore *) Semaphore;
MR_LOCK(&(sem->lock), ""semaphore__wait"");
if (sem->count > 0) {
sem->count--;
MR_UNLOCK(&(sem->lock), ""semaphore__wait"");
Res = 0;
} else {
MR_UNLOCK(&(sem->lock), ""semaphore__wait"");
Res = 1;
}
IO = IO0;
}").
-------------- next part --------------
%---------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% Main author: conway
% Stability: medium.
%
% This module provides `spawn/3' which is the primative for starting the
% concurrent execution of a goal.
%
%---------------------------------------------------------------------------%
:- module spawn.
:- interface.
:- import_module io.
% spawn(Closure, IO0, IO) is true iff IO0 denotes a list of I/O
% transactions that is an interleaving of those performed by `Closure'
% and those contained in IO - the list of transactions performed by
% the continuation of spawn.
:- pred spawn(pred(io__state, io__state), io__state, io__state).
:- mode spawn(pred(di, uo) is cc_multi, di, uo) is cc_multi.
% yield(IO0, IO) is logically equivalent to (IO = IO0) but
% operationally, yields the mercury engine to some other coroutine
% if one exists.
:- pred yield(io__state, io__state).
:- mode yield(di, uo) is det.
%---------------------------------------------------------------------------%
:- implementation.
:- pragma c_header_code("
#include <stdio.h>
").
:- pragma no_inline(spawn/3).
:- pragma c_code(spawn(Goal::(pred(di, uo) is cc_multi), IO0::di, IO::uo),
will_not_call_mercury, "{
MR_Context *ctxt;
ctxt = create_context();
ctxt->resume = &&spawn_call_back_to_mercury_cc_multi;
/* Store the closure on the top of the new context's stack. */
*(ctxt->context_sp) = Goal;
ctxt->next = NULL;
schedule(ctxt);
if (0) {
spawn_call_back_to_mercury_cc_multi:
save_registers();
/* Get the closure from the top of the stack */
call_back_to_mercury_cc_multi(*((Word *)MR_sp));
destroy_context(MR_ENGINE(this_context));
runnext();
}
IO = IO0;
}").
:- pragma no_inline(yield/2).
:- pragma c_code(yield(IO0::di, IO::uo),
will_not_call_mercury, "{
/* yield() */
save_context(MR_ENGINE(this_context));
MR_ENGINE(this_context)->resume = &&yield_skip_to_the_end;
schedule(MR_ENGINE(this_context));
runnext();
yield_skip_to_the_end:
IO = IO0;
}").
:- pred call_back_to_mercury(pred(io__state, io__state), io__state, io__state).
:- mode call_back_to_mercury(pred(di, uo) is cc_multi, di, uo) is cc_multi.
:- pragma export(call_back_to_mercury(pred(di, uo) is cc_multi, di, uo),
"call_back_to_mercury_cc_multi").
call_back_to_mercury(Goal) -->
call(Goal).
-------------- next part --------------
%---------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% Main author: conway
% Stability: medium.
%
% This module implements a simple concurrent data-stream.
%
%---------------------------------------------------------------------------%
:- module stream.
:- interface.
:- import_module io.
:- type stream(T).
:- type stream__result(T)
---> end
; error(string)
; ok(T)
.
% new(Stream, IO0, IO) creates a new data stream `Stream'.
:- pred new(stream(T), io__state, io__state).
:- mode new(out, di, uo) is det.
% get(Stream, Result, IO0, IO) blocks until a message appears
% on the data stream `Stream'. When a message arrives, `Result' is
% bound to the value of the message.
:- pred get(stream(T), stream__result(T), io__state, io__state).
:- mode get(in, out, di, uo) is det.
% put(Stream, Thing, IO0, IO) adds `Thing' to the end of the stream
% `Stream', waking a call to get/4 if necessary.
:- pred put(stream(T), T, io__state, io__state).
:- mode put(in, in, di, uo) is det.
% end(Stream, IO0, IO) puts an end-of-stream marker on the stream
% `Stream', waking a call to get/4 if necessary.
:- pred end(stream(T), io__state, io__state).
:- mode end(in, di, uo) is det.
% error(Stream, IO0, IO) puts an error message on the stream
% `Stream', waking a call to get/4 if necessary.
:- pred error(stream(T), string, io__state, io__state).
:- mode error(in, in, di, uo) is det.
%---------------------------------------------------------------------------%
:- implementation.
:- import_module queue, require.
:- import_module global, semaphore.
:- type stream(T)
---> stream(
semaphore,
global(stream0(T)),
semaphore
).
:- type stream0(T) == queue(stream__result(T)).
new(Stream) -->
{ queue__init(Queue) },
new(Queue, QueueGlob),
new(Lock), signal(Lock),
new(Semaphore),
{ Stream = stream(Lock, QueueGlob, Semaphore) }.
put(Stream, Thing) -->
{ Stream = stream(Lock, QueueGlob, Semaphore) },
wait(Lock),
get(QueueGlob, Queue0),
{ queue__put(Queue0, ok(Thing), Queue) },
set(QueueGlob, Queue),
signal(Lock),
signal(Semaphore).
end(Stream) -->
{ Stream = stream(Lock, QueueGlob, Semaphore) },
wait(Lock),
get(QueueGlob, Queue0),
{ queue__put(Queue0, end, Queue) },
set(QueueGlob, Queue),
signal(Lock),
signal(Semaphore).
error(Stream, Msg) -->
{ Stream = stream(Lock, QueueGlob, Semaphore) },
wait(Lock),
get(QueueGlob, Queue0),
{ queue__put(Queue0, error(Msg), Queue) },
set(QueueGlob, Queue),
signal(Lock),
signal(Semaphore).
get(Stream, Thing) -->
{ Stream = stream(Lock, QueueGlob, Semaphore) },
wait(Semaphore),
wait(Lock),
get(QueueGlob, Queue0),
( { queue__get(Queue0, Thing0, Queue) } ->
{ Thing = Thing0 },
set(QueueGlob, Queue)
;
{ error("stream: queue and semaphore out of sync") }
),
signal(Lock).
More information about the developers
mailing list