Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Pre-compile to de Bruijn indices. #2271

Draft
wants to merge 6 commits into
base: main
Choose a base branch
from
Draft

Pre-compile to de Bruijn indices. #2271

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
9ad3d21
Get started.
smimram Mar 3, 2022
d16063d
Progressing.
smimram Mar 3, 2022
3b88c32
More.
smimram Mar 4, 2022
7811ac0
More.
smimram Mar 4, 2022
4b799cf
Merge branch 'main' into de-bruijn
smimram Mar 4, 2022
ff803f3
More.
smimram Mar 7, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
18 changes: 9 additions & 9 deletions src/Makefile
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -127,13 +127,13 @@ encoders = \
$(if $(W_TAGLIB),encoder/taglib_id3v2.ml) \
$(if $(W_GSTREAMER),encoder/gstreamer_encoder.ml)

lang_encoders = \
lang_encoders/lang_avi.ml lang_encoders/lang_external_encoder.ml lang_encoders/lang_fdkaac.ml \
lang_encoders/lang_ffmpeg.ml $(if $(W_FFMPEG),lang_encoders/lang_ffmpeg_opt.ml) \
lang_encoders/lang_flac.ml lang_encoders/lang_gstreamer.ml \
lang_encoders/lang_mp3.ml lang_encoders/lang_opus.ml lang_encoders/lang_shine.ml \
lang_encoders/lang_speex.ml lang_encoders/lang_theora.ml lang_encoders/lang_vorbis.ml \
lang_encoders/lang_wav.ml lang_encoders/lang_ogg.ml
# lang_encoders = \
# lang_encoders/lang_avi.ml lang_encoders/lang_external_encoder.ml lang_encoders/lang_fdkaac.ml \
# lang_encoders/lang_ffmpeg.ml $(if $(W_FFMPEG),lang_encoders/lang_ffmpeg_opt.ml) \
# lang_encoders/lang_flac.ml lang_encoders/lang_gstreamer.ml \
# lang_encoders/lang_mp3.ml lang_encoders/lang_opus.ml lang_encoders/lang_shine.ml \
# lang_encoders/lang_speex.ml lang_encoders/lang_theora.ml lang_encoders/lang_vorbis.ml \
# lang_encoders/lang_wav.ml lang_encoders/lang_ogg.ml

encoder_formats = \
encoder_formats.ml \
Expand Down Expand Up @@ -261,7 +261,7 @@ liquidsoap_sources = \

liquidsoap_sources += \
lang/type.ml lang/repr.ml lang/typing.ml \
lang/profiler.ml lang/term.ml lang/value.ml \
lang/profiler.ml lang/term.ml lang/termDB.ml lang/value.ml \
lang/lang_encoder.ml $(lang_encoders) \
lang/environment.ml lang/typechecking.ml \
lang/evaluation.ml lang/error.ml \
Expand Down Expand Up @@ -290,7 +290,7 @@ export OCAMLPATH := $(OCAMLPATH)

OCAMLDEP_FLAGS = $(patsubst %,-I %,$(INCDIRS))
OCAML_CFLAGS = -thread $(OCAMLDEP_FLAGS)
_OCAML_CFLAGS = $(liquidsoap_ocamlcflags)
_OCAML_CFLAGS = $(liquidsoap_ocamlcflags) -w -40-42
_OCAML_LFLAGS = $(liquidsoap_ocamllflags)

liquidsoap_mly = $(wildcard $(liquidsoap_sources:.ml=.mly))
Expand Down
5 changes: 2 additions & 3 deletions src/lang/environment.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -75,7 +75,7 @@ let add_builtin ?(override = false) ?(register = true) ?doc name ((g, t), v) =
in
(* Update value for x.l1...li. *)
let value = Value.Meth (l, lv, v) in
((vg, t), { Value.pos = v.Value.pos; value })
((vg, t), value)
| [] -> ((g, t), v)
in
let (g, t), v = aux [] ll in
Expand Down Expand Up @@ -108,8 +108,7 @@ let add_module name =
ignore (Value.invoke e l);
failwith ("Module " ^ String.concat "." name ^ " already exists")
with _ -> ()));
add_builtin ~register:false name
(([], Type.make Type.unit), { Value.pos = None; value = Value.unit })
add_builtin ~register:false name (([], Type.make Type.unit), Value.unit)

(* Builtins are only used for documentation now. *)
let builtins = (builtins :> Doc.item)
173 changes: 71 additions & 102 deletions src/lang/evaluation.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -41,21 +41,14 @@ let remove_first filter =
let rec rev_map_append f l1 l2 =
match l1 with [] -> l2 | a :: l -> rev_map_append f l (f a :: l2)

let lookup (env : Value.lazy_env) var =
try Lazy.force (List.assoc var env)
with Not_found ->
failwith
(Printf.sprintf "Internal error: variable %s not in environment." var)

let rec eval_pat pat v =
let rec aux env pat v =
let rec aux env (pat : TermDB.pattern) (v : Value.t) =
match (pat, v) with
| PVar x, v -> (x, v) :: env
| PTuple pl, { Value.value = Value.Tuple l } ->
List.fold_left2 aux env pl l
(* The parser parses [x,y,z] as PList ([], None, l) *)
| PList (([] as l'), (None as spread), l), { Value.value = Value.List lv }
| PList (l, spread, l'), { Value.value = Value.List lv } ->
| PTuple pl, Tuple l -> List.fold_left2 aux env pl l
(* The parser parses [x,y,z] as PList ([], false, l) *)
| PList (([] as l'), (None as spread), l), List lv
| PList (l, spread, l'), List lv ->
let ln = List.length l in
let ln' = List.length l' in
let lvn = List.length lv in
Expand Down Expand Up @@ -84,9 +77,7 @@ let rec eval_pat pat v =
List.map snd (List.filter (fun (lbl, _) -> lbl = `Second) lv)
in
let spread_env =
match spread with
| None -> []
| Some s -> [([s], Value.{ v with value = List ls })]
match spread with None -> [] | Some s -> [([s], Value.List ls)]
in
List.fold_left2 aux [] l' ll'
@ spread_env @ env
Expand All @@ -106,50 +97,32 @@ let rec eval_pat pat v =
in
aux [] pat v

let rec eval ~env tm =
let env = (env : Value.lazy_env) in
let prepare_fun fv p env =
module Env = Value.Env

let rec eval (env : Env.t) (tm : TermDB.t) : Value.t =
let eval_fun_params p =
(* Unlike OCaml we always evaluate default values, and we do that early. I
think the only reason is homogeneity with FFI, which are declared with
values as defaults. *)
let p =
List.map
(function
| lbl, var, _, Some v -> (lbl, var, Some (eval ~env v))
| lbl, var, _, None -> (lbl, var, None))
p
in
(* Keep only once the variables we might use in the environment. *)
let env =
let fv = ref fv in
let mem x =
if Vars.mem x !fv then (
fv := Vars.remove x !fv;
true)
else false
in
List.filter (fun (x, _) -> mem x) env
in
(p, env)
List.map (fun (lbl, var, _, v) -> (lbl, var, Option.map (eval env) v)) p
in
let mk v =
(* Ensure that the kind computed at runtime for sources will agree with
the typing. *)
(match (Type.deref tm.t).Type.descr with
| Type.Constr
{ Type.constructor = "source"; params = [(Type.Invariant, k)] } -> (
(* Ensure that the kind computed at runtime for sources will agree with the
typing. *)
let cast v t =
match (Type.deref t).descr with
| Constr { Type.constructor = "source"; params = [(Type.Invariant, k)] }
-> (
let frame_content_of_t t =
match (Type.deref t).Type.descr with
| Type.Var _ -> `Any
| Type.Constr { Type.constructor; params = [(_, t)] } -> (
| Var _ -> `Any
| Constr { Type.constructor; params = [(_, t)] } -> (
match (Type.deref t).Type.descr with
| Type.Ground (Type.Format fmt) -> `Format fmt
| Type.Var _ -> `Kind (Content.kind_of_string constructor)
| _ -> failwith ("Unhandled content: " ^ Type.to_string tm.t)
)
| Type.Constr { Type.constructor = "none" } ->
| _ -> failwith ("Unhandled content: " ^ Type.to_string t))
| Constr { Type.constructor = "none" } ->
`Kind (Content.kind_of_string "none")
| _ -> failwith ("Unhandled content: " ^ Type.to_string tm.t)
| _ -> failwith ("Unhandled content: " ^ Type.to_string t)
in
let k = of_frame_kind_t k in
let k =
Expand All @@ -161,24 +134,24 @@ let rec eval ~env tm =
}
in
let rec demeth = function
| Value.Meth (_, _, v) -> demeth v.Value.value
| Value.Meth (_, _, v) -> demeth v
| v -> v
in
match demeth v with
| Value.Source s -> Kind.unify s#kind k
| _ ->
raise
(Internal_error
( Option.to_list tm.t.Type.pos,
( Option.to_list t.Type.pos,
"term has type source but is not a source: "
^ Value.print_value
{ Value.pos = tm.t.Type.pos; Value.value = v } )))
| _ -> ());
{ Value.pos = tm.t.Type.pos; Value.value = v }
^ Value.print_value v )))
| _ -> ()
in
match tm.term with
| Ground g -> mk (Value.Ground g)
| Encoder (e, p) ->
match tm with
| Ground g -> Ground g
| Encoder _ ->
(* | Encoder (e, p) -> *)
(*
let pos = tm.t.Type.pos in
let rec eval_param p =
List.map
Expand All @@ -193,59 +166,57 @@ let rec eval ~env tm =
let enc : Value.encoder = (e, p) in
let e = Lang_encoder.make_encoder ~pos tm enc in
mk (Value.Encoder e)
| List l -> mk (Value.List (List.map (eval ~env) l))
| Tuple l -> mk (Value.Tuple (List.map (fun a -> eval ~env a) l))
| Null -> mk Value.Null
| Cast (e, _) ->
let e = eval ~env e in
mk e.Value.value
| Meth (l, u, v) -> mk (Value.Meth (l, eval ~env u, eval ~env v))
*)
failwith "TODO"
| List l -> List (List.map (eval env) l)
| Tuple l -> Tuple (List.map (fun a -> eval env a) l)
| Null -> Null
| Cast (e, t) ->
let e = eval env e in
cast e t;
e
| Meth (l, u, v) -> Meth (l, eval env u, eval env v)
| Invoke (t, l) ->
let rec aux t =
match t.Value.value with
match t with
| Value.Meth (l', t, _) when l = l' -> t
| Value.Meth (_, _, t) -> aux t
| _ ->
raise
(Internal_error
( Option.to_list tm.t.Type.pos,
( [] (* TODO: can we find a relevant position ? *),
"invoked method `" ^ l ^ "` not found" ))
in
aux (eval ~env t)
aux (eval env t)
| Open (t, u) ->
let t = eval ~env t in
let rec aux env t =
match t.Value.value with
| Value.Meth (l, v, t) -> aux ((l, Lazy.from_val v) :: env) t
| Value.Tuple [] -> env
let t = eval env t in
let rec aux (env : Env.t) (t : Value.t) =
match t with
| Meth (l, v, t) -> aux (Env.add env v) t
| Tuple [] -> env
| _ -> assert false
in
let env = aux env t in
eval ~env u
eval env u
| Let { pat; replace; def = v; body = b; _ } ->
let v = eval ~env v in
let v = eval env v in
let penv =
List.map
(fun (ll, v) ->
match ll with
| [] -> assert false
| [x] ->
let v () =
if replace then
Value.remeth (Lazy.force (List.assoc x env)) v
else v
if replace then Value.remeth (Env.lookup env x) v else v
in
(x, Lazy.from_fun v)
| l :: ll ->
(* Add method ll with value v to t *)
let rec meths ll v t =
let mk ~pos value = { Value.pos; value } in
let rec meths ll v t : Value.t =
match ll with
| [] -> assert false
| [l] -> mk ~pos:tm.t.Type.pos (Value.Meth (l, v, t))
| l :: ll ->
mk ~pos:t.Value.pos
(Value.Meth (l, meths ll v (Value.invoke t l), t))
| [l] -> Meth (l, v, t)
| l :: ll -> Meth (l, meths ll v (Value.invoke t l), t)
in
let v () =
let t = Lazy.force (List.assoc l env) in
Expand All @@ -260,31 +231,29 @@ let rec eval ~env tm =
(eval_pat pat v)
in
let env = penv @ env in
eval ~env b
| Fun (fv, p, body) ->
let p, env = prepare_fun fv p env in
mk (Value.Fun (p, env, body))
| RFun (x, fv, p, body) ->
let p, env = prepare_fun fv p env in
eval env b
| Fun (p, body) ->
let p = eval_fun_params p in
Fun (p, env, body)
| RFun (p, body) ->
let p = eval_fun_params p in
let rec v () =
let env = (x, Lazy.from_fun v) :: env in
{ Value.pos = tm.t.Type.pos; value = Value.Fun (p, env, body) }
let env = Env.add_lazy env (Lazy.from_fun v) in
Value.Fun (p, env, body)
in
v ()
| Var var -> lookup env var
| Var (var, _) -> Env.lookup env var
| Seq (a, b) ->
ignore (eval ~env a);
eval ~env b
ignore (eval env a);
eval env b
| App (f, l) ->
let ans () =
let f = eval ~env f in
let l = List.map (fun (l, t) -> (l, eval ~env t)) l in
let f = eval env f in
let l = List.map (fun (l, t) -> (l, eval env t)) l in
apply f l
in
if !profile then (
match f.term with
| Var fname -> Profiler.time fname ans ()
| _ -> ans ())
match f with Var fname -> Profiler.time fname ans () | _ -> ans ())
else ans ()

and apply f l =
Expand Down Expand Up @@ -465,8 +434,8 @@ let toplevel_add (doc, params, methods) pat ~t v =
((generalized, t), v))
(eval_pat pat v)

let rec eval_toplevel ?(interactive = false) t =
match t.term with
let rec eval_toplevel ?(interactive = false) (t : TermDB.t) =
match t with
| Let { doc = comment; gen = generalized; replace; pat; def; body } ->
let def_t, def =
if not replace then (def.t, eval def)
Expand Down
4 changes: 2 additions & 2 deletions src/lang/lang_encoder.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,10 +40,10 @@ let error ~pos msg =
pos = (match pos with None -> [] | Some pos -> [pos]);
})

let generic_error (l, t) : exn =
let generic_error (l, pos, t) : exn =
match t with
| `Value v ->
error ~pos:v.Value.pos
error ~pos
(Printf.sprintf
"unknown parameter name (%s) or invalid parameter value (%s)" l
(Value.print_value v))
Expand Down
4 changes: 2 additions & 2 deletions src/lang/runtime.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,14 +28,14 @@ let type_and_run ~throw ~lib ast =
Clock.collect_after (fun () ->
if Lazy.force Term.debug then Printf.eprintf "Type checking...\n%!";
(* Type checking *)
Typechecking.check ~throw ~ignored:true ast;
let ast' = Typechecking.check ~throw ~ignored:true ast in

if Lazy.force Term.debug then
Printf.eprintf "Checking for unused variables...\n%!";
(* Check for unused variables, relies on types *)
Term.check_unused ~throw ~lib ast;
if Lazy.force Term.debug then Printf.eprintf "Evaluating...\n%!";
ignore (Evaluation.eval_toplevel ast))
ignore (Evaluation.eval_toplevel ast'))

(** {1 Error reporting} *)

Expand Down
Loading