Permalink
Browse files

[enhance] compiler, lambda lifting: Propagates free type/row/col vari…

…able used in typeval expression by lifted functions
  • Loading branch information...
BourgerieQuentin committed Nov 15, 2012
1 parent c7cb78b commit 93d28234ffb6e0e81a8d252b9d81e1f20e85249a
@@ -222,3 +222,5 @@ let light_ident = function
Printf.sprintf "__%s" id
else
Printf.sprintf "_v%d_%s" n id
+
+let from_fresh f = Internal f
@@ -103,3 +103,5 @@ val get_package_name : t -> string
val safe_get_package_name : t -> string option
val renaming_should_warn_when : t -> [`used | `unused | `never]
+
+val from_fresh : Fresh.t_fresh -> t
@@ -1156,7 +1156,10 @@ type qml_directive = [
| `assert_ (**As [assert]. : if --no-assert is enabled, all this directive without exception are ignored ('assert false' too) *)
| `fail (**As [assert false], with a message. : always fails, no matter if --no-assert is enabled or not. type : 'a *)
| `typeof (** -> WIP, don't use (yet) *)
- | `typeval
+ | `typeval of
+ (Ident.t QTV.TypeVarMap.t
+ * Ident.t QTV.RowVarMap.t
+ * Ident.t QTV.ColVarMap.t) option
| `expand of Big_int.big_int option (**Marker for macro (function) that are macro-expanded, the integer represents the number of unrolling the compiler is authorised to do, it must do at least one *)
| `restricted_bypass of string
@@ -241,7 +241,7 @@ let ty directive exprs tys =
(* === *)
(* Magic *)
| `typeof -> Ty.typeof ()
- | `typeval -> Ty.typeval()
+ | `typeval _ -> Ty.typeval()
| `specialize _ ->
let n = List.length exprs in
assert (n >= 1);
@@ -456,7 +456,8 @@ let to_string d =
| `extendwith -> "extendwith"
| `assert_ -> "assert"
| `typeof -> "typeof"
- | `typeval -> "typeval"
+ | `typeval None -> "typeval"
+ | `typeval Some _subst -> "typeval[]"
| `atomic -> "atomic"
| `immovable -> "immovable"
| `thread_context -> "thread_context"
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of Opa.
@@ -49,7 +49,7 @@ let map_on_type_from_expr f expr =
| _ -> pat)
expr
-module MakeFind(Tbl:Hashtbl.S)(Map:BaseMapSig.S with type key = Tbl.key)(Var:Fresh.FRESH with type t = Tbl.key) =
+module MakeFind(Tbl:Hashtbl.S with type key = Fresh.t_fresh)(Map:BaseMapSig.S with type key = Fresh.t_fresh)(Var:Fresh.FRESH) =
struct
let h = PackageTbl.create 10
let clear () = PackageTbl.clear h
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of Opa.
@@ -29,7 +29,7 @@
module type GEN_VAR = Fresh.FRESH
-module MakeVar ( FB : Fresh.BRAND ) : GEN_VAR =
+module MakeVar ( FB : Fresh.BRAND ) : Fresh.FRESH =
Fresh.FreshGen ( FB )
let var_printer s =
@@ -147,6 +147,11 @@ struct
colvar = ColVarSet.map f_cv f.colvar
}
+ let size a =
+ TypeVarSet.size a.typevar +
+ RowVarSet.size a.rowvar +
+ ColVarSet.size a.colvar
+
let mem_typevar v f = TypeVarSet.mem v f.typevar
let mem_rowvar rv f = RowVarSet.mem rv f.rowvar
let mem_colvar cv f = ColVarSet.mem cv f.colvar
@@ -139,6 +139,8 @@ sig
val compare : t -> t -> int
+ val size : t -> int
+
val mem_typevar : QmlAst.typevar -> t -> bool
val mem_rowvar : QmlAst.rowvar -> t -> bool
val mem_colvar : QmlAst.colvar -> t -> bool
@@ -567,7 +567,7 @@ struct
and directive opa_annot ((c, e, t) as d) : QA.expr =
match c, e, t with
| (
- `typeof | `typeval | `opensums | `openrecord | `extendwith | `unsafe_cast
+ `typeof | `opensums | `openrecord | `extendwith | `unsafe_cast
| `nonexpansive | `doctype _ | `module_ | `module_field_lifting
| `spawn | `wait | `atomic | `callcc | `js_ident | `expand _
| `create_lazy_record | `assert_ | `fail
@@ -596,6 +596,11 @@ struct
QA.Coerce ((make_label_from_opa_annot opa_annot), e, t)
| `coerce, _, _ -> assert false
+ | `typeval, e, t ->
+ let e = List.map expr e in
+ let t = List.map ty t in
+ QA.Directive ((make_label_from_opa_annot opa_annot), `typeval None, e, t)
+
| `warncoerce, _, _ ->
(*
Currently, this directive is not in the syntax,
Oops, something went wrong.

0 comments on commit 93d2823

Please sign in to comment.