Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

wip

  • Loading branch information...
commit 1851a1bd16e542dda49fd8ac66285a289cff50a6 1 parent acf1c6a
@Aqua-Ye Aqua-Ye authored
View
4 compiler/opa/_tags
@@ -57,8 +57,8 @@
<opa_parse.ml>: use_opalib, use_opalang, use_opapasses
# s3 main
-<s3Passes.{ml,mli}>: use_pplib, use_libqmlcompil, use_opalib, use_qmlslicer, use_passlib, use_opapasses, use_qml2ocaml, use_opalang, use_libbsl, use_qmlfakecompiler, use_qmlflatcompiler, use_ocamllang, use_qmlpasses, use_qml2js, use_jslang
-<{main,gen_opa_manpage}.ml>: use_opalib, use_opalang, use_opapasses, use_libqmlcompil, use_qml2ocaml, use_passlib
+<{s3Passes,qmljsPasses,qmlflatPasses}.{ml,mli}>: use_pplib, use_libqmlcompil, use_opalib, use_qmlslicer, use_passlib, use_opapasses, use_qml2ocaml, use_opalang, use_libbsl, use_qmlfakecompiler, use_ocamllang, use_qmlpasses, use_qml2js, use_jslang, use_qmlflatcompiler
+<{main,compiler,gen_opa_manpage}.ml>: use_opalib, use_opalang, use_opapasses, use_libqmlcompil, use_qml2ocaml, use_passlib, use_libbsl, use_qmlflatcompiler, use_qml2ocaml, use_qml2js
<syntaxHelper.ml>: use_opalib, use_opalang, use_opapasses, use_libqmlcompil, use_qml2ocaml, use_passlib
# linking
View
353 compiler/opa/compiler.ml
@@ -0,0 +1,353 @@
+(*
+ Copyright © 2011, 2012 MLstate
+
+ This file is part of Opa.
+
+ Opa is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ Opa is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with Opa. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+(** The main program for the OPA compiler. S3 version. *)
+
+(* Opening the generic pass system. *)
+module PH = PassHandler
+
+(* FIXME: define a module InfixOperators in PassHandler *)
+(* this could by the only case an 'open' is allowed *)
+let (|+>) = PH.(|+>)
+let (|>) = PH.(|>)
+let (<?>) = PH.(<?>)
+let (&) = PH.(&)
+let (|?>) = PH.(|?>)
+let (|?|) = PH.(|?|)
+let (or) = PH.(or)
+
+(* Shorthands for accessing options of compilation *)
+module If = Main_utils.If
+module Switch = Main_utils.Switch
+
+(* The deprecated passes *)
+(* FIXME: adapt to the new PassHandler *)
+module S2 = Passes
+
+(* S3 implementations. *)
+module S3 = S3Passes
+
+type ('opt, 'opt2, 'env, 'env2) backend_handler = {
+ name : string;
+ aliases : string list;
+ pass : ('opt, 'opt2, 'env, 'env2) PH.pass;
+ dynloader : (BslPluginInterface.plugin -> unit) option;
+ bsl_lang : BslLanguage.t;
+ register_fields : string -> unit;
+}
+
+let make_backend name ?(aliases=[]) pass dynloader bsl_lang register_fields = {
+ name = name;
+ aliases = aliases;
+ pass = pass;
+ dynloader = dynloader;
+ bsl_lang = bsl_lang;
+ register_fields = register_fields;
+}
+
+let compute_backend_options backend_handlers =
+ List.map (
+ fun backend_handler ->
+ backend_handler.name :: backend_handler.aliases
+ ) backend_handlers |> List.flatten
+
+(* Run all passes *)
+let compile backend_handlers =
+
+ let backend_options = compute_backend_options backend_handlers in
+ let unify_backend_name =
+ fun (OpaEnv.Backend b) ->
+ let rec find_backend l =
+ match l with
+ | hd :: tl ->
+ if hd.name = b || (List.mem b hd.aliases) then
+ OpaEnv.Backend hd.name
+ else find_backend tl
+ | [] ->
+ OManager.error "The back-end @{<bright>%s@} is not recognized" (b);
+ in find_backend backend_handlers
+ in
+ let backend_pass_switcher =
+ fun (OpaEnv.Backend b) ->
+ let rec find_backend l =
+ match l with
+ | hd :: tl ->
+ if hd.name = b
+ || (List.mem b hd.aliases) then
+ ((Printf.sprintf "%sCompilation" hd.name), hd.pass)
+ else find_backend tl
+ | [] ->
+ OManager.error "The back-end @{<bright>%s@} is not recognized" (b);
+ in find_backend backend_handlers
+ in
+ let backend_dynloader_switcher =
+ fun (OpaEnv.Backend b) ->
+ let rec find_backend l =
+ match l with
+ | hd :: tl ->
+ if hd.name = b || (List.mem b hd.aliases) then
+ (hd.dynloader, hd.bsl_lang)
+ else find_backend tl
+ | [] ->
+ OManager.error "The back-end @{<bright>%s@} is not recognized" (b);
+ in find_backend backend_handlers
+ in
+ let backend_register_fields_switcher =
+ fun (OpaEnv.Backend b) ->
+ let rec find_backend l =
+ match l with
+ | hd :: tl ->
+ if hd.name = b || (List.mem b hd.aliases) then
+ hd.register_fields
+ else find_backend tl
+ | [] ->
+ OManager.error "The back-end @{<bright>%s@} is not recognized" (b);
+ in find_backend backend_handlers
+ in
+
+ (**********************************************)
+ (* INITIALIZATION *****************************)
+ PH.init
+
+ |+> ("Welcome", (S3.pass_Welcome backend_options))
+
+ |+> ("CheckOptions", (S3.pass_CheckOptions unify_backend_name))
+
+ |+> ("AddStdlibFiles", S3.pass_AddStdlibFiles)
+
+ |> PH.old_handler
+ "OpenFiles" S2.pass_OpenFiles
+
+ |+> ("PreProcess", S3.pass_PreProcess)
+
+ |+> ("Parse", S3.pass_Parse)
+
+ |+> ("PluginCompilation", PH.make_pass Pass_PluginCompilation.process)
+
+ (**********************************************)
+ (* SURFACE AST PASSES *************************)
+ |> PH.handler ~count_time:false "LoadObjects" (S3.pass_LoadObjects (
+ fun e -> e
+
+ |+> ("DbEngineImportation", S3.pass_DbEngineImportation)
+
+ |+> ("BslLoading", S3.pass_BslLoading backend_dynloader_switcher)
+
+ |+> ("ConvertStructure", S3.pass_ConvertStructure)
+
+ |> PH.old_handler
+ "CheckOptionsConsistency" (Pass_CheckOptionsConsistency.process_code)
+
+ |+> ("CheckServerEntryPoint", S3.pass_CheckServerEntryPoint)
+
+ |+> ("ParserGeneration", S3.pass_ParserGeneration)
+
+ |+> ("CheckDuplication", S3.pass_CheckDuplication)
+
+ (* I18n, exit if generating template *)
+ |+> ("I18nAndComputedString", S3.pass_I18nAndComputedString)
+
+ |+> ("ConvertStructure2", S3.pass_ConvertStructure2 ())
+
+ |+> ("TreatNoClientCalls",S3.pass_TreatNoClientCalls ())
+
+ |> PH.old_handler
+ "ReplaceCompileTimeDirective" S2.pass_ReplaceCompileTimeDirective
+
+ |> PH.old_if_handler
+ "StaticInclusionDirectory" S2.pass_static_inclusion_directory
+
+ |> PH.old_if_handler
+ "StaticInclusions" S2.pass_static_inclusions
+
+ |> PH.old_if_handler ~if_:If.server
+ "ServerEntryPoint" S2.pass_resolve_server_entry_point
+
+ (* inserting doctype directive for a collection later
+ currently always enable until an automated test verify that nobody breaks it
+ *)
+ |+> ((*PH.old_if_handler ~if_:If.generate_interface, *)
+ "AddDocApiDirectives", (S3.pass_AddDocApiDirectives ()))
+
+ |> PH.old_if_handler
+ "TupleTypeGeneration" S2.pass_tuple_types
+
+ |+> ("Reorder", (S3.pass_ReorderToplevel ()))
+
+ |+> ("RewriteModules", (S3.pass_RewriteModules ()))
+
+ |> PH.old_if_handler ~if_:If.server
+ "AddingServer" S2.pass_adding_server
+
+ (**********************************************)
+ (* QML AST PASSES *****************************)
+ |+> ("SAtoQML", S3.pass_SaToQml)
+
+ |+> ("AddCSS", S3.pass_AddCSS)
+
+ |+> ("FunActionLifting", S3.pass_FunActionLifting)
+
+ |+> ("TypesDefinitions", (S3.pass_TypesDefinitions backend_register_fields_switcher))
+
+ |+> ("DbSchemaGeneration", S3.pass_DbSchemaGeneration)
+
+ |+> ("DbPathCoercion", S3.pass_DbPathCoercion)
+
+ |+> ("MacroExpansion", S3.pass_MacroExpansion)
+
+ |+> ("Typing", S3.pass_Typing)
+
+ (* Extracting interesting types for documentation *)
+ |+> ("DocApiGeneration", S3.pass_DocApiGeneration)(*~if_:If.generate_interface*)
+
+ |+> ("CheckPatternMatching", S3.pass_CheckPatternMatching)
+
+ |+> ("WarnCoerce", S3.pass_WarnCoerce)
+
+ |+> ("CompileRecursiveValues", S3.pass_CompileRecursiveValues)
+
+ |+> ("RewriteAsyncLambda", S3.pass_RewriteAsyncLambda)
+
+ (*|+> ("Retyping", S3.pass_Retyping)*)
+
+ |?> (If.database `db3,
+ "BadopCodeGeneration", S3.pass_BadopCodeGeneration)
+
+ |?> (If.database `mongo,
+ "MongoCodeGeneration", S3.pass_MongoCodeGeneration)
+
+ |?> (If.database `dropbox,
+ "DropBoxCodeGeneration", S3.pass_DropBoxCodeGeneration)
+
+ (* could be just after typing, if dbgen didn't complain that it can't find its coercions :/ *)
+ |+> ("PurgeTypeDirectivesAfterTyping", S3.pass_PurgeTypeDirectiveAfterTyping)
+
+ |> PH.handler ~count_time:false "EndOfSeparateCompilation" (S3.pass_EndOfSeparateCompilation (fun e -> e
+
+ |+> ("BypassHoisting", S3.pass_BypassHoisting)
+
+ |+> ("RegisterFields", (S3.pass_RegisterFields backend_register_fields_switcher))
+
+ |?> (If.undot,
+ "Undot", S3.pass_QmlUndot)
+
+ |+> ("CodingDirectives", S3.pass_CodingDirectives)
+
+ <?> (If.closure,
+ ("EnrichMagic", S3.pass_EnrichMagic),
+ ("EnrichMagicPurge", S3.pass_EnrichMagicPurge))
+
+ |+> ("SimplifyEquality", S3.pass_SimplifyEquality)
+
+ |+> ("SimplifyMagic", S3.pass_SimplifyMagic)
+
+ |+> ("JustReorder1", S3.pass_ReorderEnvGen)
+
+ |> PH.old_if_handler
+ "EarlyLambdaLifting" S2.pass_EarlyLambdaLifting
+
+ |+> ("InstrumentForClosureSerialization", S3.pass_InstrumentForClosureSerialization)
+
+ (**********************************************)
+ (* SLICED PASSES ******************************)
+ <?> (If.server or If.separated or If.slicer_test,
+ ("Slicing" , S3.pass_SimpleSlicer),
+ ("NoSlicing", S3.pass_NoSlicer))
+
+ |+> ("Assertion", S3.pass_Assertion)
+
+ |?> (PH.neg (If.no_discard_of_unused_stdlib or If.separated),
+ "SlicedCleaning", S3.pass_SlicedCleaning)
+
+ (* Fun action resolution, step 2/3 *)
+ |?> (If.server or If.separated,
+ "FunActionEnvSerialize", S3.pass_FunActionEnvSerialize)
+
+ (* Explicit instantiation *)
+ |?> (If.explicit_instantiation,
+ "ExplicitInstantiation", S3.pass_ExplicitInstantiation)
+
+ |?> (If.explicit_instantiation,
+ "OptimizeExplicitInstantiation", S3.pass_OptimizeExplicitInstantiation)
+
+ (* Fun action resolution, step 3/3 *)
+ |?> (If.server or If.separated,
+ "FunActionJsCallGeneration", S3.pass_FunActionJsCallGeneration)
+
+ |+> ("PurgeTypeDirectivesAfterEi", S3.pass_PurgeTypeDirectiveAfterEi)
+
+ |?> (If.explicit_instantiation & (If.server or If.separated),
+ "ResolveRemoteCalls", S3.pass_ResolveRemoteCalls)
+
+ |?> (If.explicit_instantiation,
+ "InsertMemoizedTypes", S3.pass_InsertMemoizedTypes)
+
+ |+> ("JustReorder2", S3.pass_SlicedReorder)
+
+ (* ***********************************************)
+ (* FINAL COMPILATION *****************************)
+ |+> ("SlicedToFinal", S3.pass_SlicedToFinal)
+
+ (* ***********************************************)
+ (* FINAL CLIENT COMPILATION **********************)
+
+ |?> (If.cps_client,
+ "ClientQmlCpsRewriter", S3.pass_ClientCpsRewriter)
+
+ |?> (If.closure,
+ "ClientQmlLambdaLifting", S3.pass_ClientLambdaLifting)
+
+ |?> (If.constant_sharing_client,
+ "QmlClientConstantSharing", S3.pass_ClientQmlConstantSharing)
+ (* Insert client code like a js string on server (if
+ necessary) - After that client qml code have no more
+ place to exist and it dropped *)
+ |+> ("JavascriptCompilation", S3.pass_JavascriptCompilation)
+
+ |?> (If.server or If.separated,
+ "ResolveJsIdent", S3.pass_ResolveJsIdent)
+
+ <?> (If.server or If.separated,
+ ("GenerateServerAst", S3.pass_GenerateServerAst true),
+ ("DontGenerateServerAst", S3.pass_GenerateServerAst false))
+
+ (* ***********************************************)
+ (* FINAL SERVER COMPILATION **********************)
+
+ (* |+> ("CleanLambdaLiftingDirectives", S3.pass_CleanLambdaLiftingDirectives) *)
+
+ |?> (If.init & If.server,
+ "InitializeBslValues", S3.pass_InitializeBslValues)
+
+ |+> ("ServerQmlCpsRewriter", S3.pass_ServerCpsRewriter)
+
+ |?| (Switch.back_end, backend_pass_switcher)
+
+ |+> ("CleanUp", S3.pass_CleanUp)
+
+ |+> ("ByeBye", S3.pass_ByeBye)
+
+ |> PH.return )) (* end of the pass endOfSeparateCompilation *)
+ |> PH.return )) (* end of the pass loadObjects *)
+ |> PH.return
+
+(* Set title of generic pass system. *)
+let _ = PH.set_title "Opa.exe"
+
+(* Load warnings of opa s3 applications *)
+let _ = WarningClass.load_set S3Warnings.warning_set
View
279 compiler/opa/main.ml
@@ -42,272 +42,53 @@ module S2 = Passes
(* S3 implementations. *)
module S3 = S3Passes
-(* Set title of generic pass system. *)
-let _ = PH.set_title "Opa.exe"
+let flat_backend = Compiler.make_backend "qmlflat"
+ ~aliases:["native"] (
+ PassHandler.make_pass (
+ fun e -> e
-(* Load warnings of opa s3 applications *)
-let _ = WarningClass.load_set S3Warnings.warning_set
+ |> PH.old_if_handler ~if_:If.closure
+ "ServerQmlLambdaLifting" (S2.pass_LambdaLifting2 ~typed:false ~side:`server)
-(* Run all passes *)
-let () =
- (**********************************************)
- (* INITIALIZATION *****************************)
- PH.init
+ |?> (If.constant_sharing,
+ "QmlConstantSharing", S3.pass_QmlConstantSharing)
- |+> ("Welcome", S3.pass_Welcome)
-
- |+> ("CheckOptions", S3.pass_CheckOptions)
-
- |+> ("AddStdlibFiles", S3.pass_AddStdlibFiles)
-
- |> PH.old_handler
- "OpenFiles" S2.pass_OpenFiles
-
- |+> ("PreProcess", S3.pass_PreProcess)
-
- |+> ("Parse", S3.pass_Parse)
-
- |+> ("PluginCompilation", PH.make_pass Pass_PluginCompilation.process)
-
- (**********************************************)
- (* SURFACE AST PASSES *************************)
- |> PH.handler ~count_time:false "LoadObjects" (S3.pass_LoadObjects (fun e -> e
-
- |+> ("DbEngineImportation", S3.pass_DbEngineImportation)
-
- |+> ("BslLoading", S3.pass_BslLoading)
-
- |+> ("ConvertStructure", S3.pass_ConvertStructure)
-
- |> PH.old_handler
- "CheckOptionsConsistency" Pass_CheckOptionsConsistency.process_code
-
- |+> ("CheckServerEntryPoint", S3.pass_CheckServerEntryPoint)
-
- |+> ("ParserGeneration", S3.pass_ParserGeneration)
-
- |+> ("CheckDuplication", S3.pass_CheckDuplication)
-
- (* I18n, exit if generating template *)
- |+> ("I18nAndComputedString", S3.pass_I18nAndComputedString)
-
- |+> ("ConvertStructure2", S3.pass_ConvertStructure2 ())
-
- |+> ("TreatNoClientCalls",S3.pass_TreatNoClientCalls ())
-
- |> PH.old_handler
- "ReplaceCompileTimeDirective" S2.pass_ReplaceCompileTimeDirective
-
- |> PH.old_if_handler
- "StaticInclusionDirectory" S2.pass_static_inclusion_directory
-
- |> PH.old_if_handler
- "StaticInclusions" S2.pass_static_inclusions
-
- |> PH.old_if_handler ~if_:If.server
- "ServerEntryPoint" S2.pass_resolve_server_entry_point
-
- (* inserting doctype directive for a collection later
- currently always enable until an automated test verify that nobody breaks it
- *)
- |+> ((*PH.old_if_handler ~if_:If.generate_interface, *)
- "AddDocApiDirectives", (S3.pass_AddDocApiDirectives ()))
-
- |> PH.old_if_handler
- "TupleTypeGeneration" S2.pass_tuple_types
-
- |+> ("Reorder", (S3.pass_ReorderToplevel ()))
-
- |+> ("RewriteModules", (S3.pass_RewriteModules ()))
-
- |> PH.old_if_handler ~if_:If.server
- "AddingServer" S2.pass_adding_server
-
- (**********************************************)
- (* QML AST PASSES *****************************)
- |+> ("SAtoQML", S3.pass_SaToQml)
-
- |+> ("AddCSS", S3.pass_AddCSS)
-
- |+> ("FunActionLifting", S3.pass_FunActionLifting)
-
- |+> ("TypesDefinitions", S3.pass_TypesDefinitions)
-
- |+> ("DbSchemaGeneration", S3.pass_DbSchemaGeneration)
-
- |+> ("DbPathCoercion", S3.pass_DbPathCoercion)
-
- |+> ("MacroExpansion", S3.pass_MacroExpansion)
-
- |+> ("Typing", S3.pass_Typing)
-
- (* Extracting interesting types for documentation *)
- |+> ("DocApiGeneration", S3.pass_DocApiGeneration)(*~if_:If.generate_interface*)
-
- |+> ("CheckPatternMatching", S3.pass_CheckPatternMatching)
-
- |+> ("WarnCoerce", S3.pass_WarnCoerce)
-
- |+> ("CompileRecursiveValues", S3.pass_CompileRecursiveValues)
-
- |+> ("RewriteAsyncLambda", S3.pass_RewriteAsyncLambda)
-
- (*|+> ("Retyping", S3.pass_Retyping)*)
-
- |?> (If.database `db3,
- "BadopCodeGeneration", S3.pass_BadopCodeGeneration)
-
- |?> (If.database `mongo,
- "MongoCodeGeneration", S3.pass_MongoCodeGeneration)
-
- |?> (If.database `dropbox,
- "DropBoxCodeGeneration", S3.pass_DropBoxCodeGeneration)
-
- (* could be just after typing, if dbgen didn't complain that it can't find its coercions :/ *)
- |+> ("PurgeTypeDirectivesAfterTyping", S3.pass_PurgeTypeDirectiveAfterTyping)
-
- |> PH.handler ~count_time:false "EndOfSeparateCompilation" (S3.pass_EndOfSeparateCompilation (fun e -> e
-
- |+> ("BypassHoisting", S3.pass_BypassHoisting)
-
- |+> ("RegisterFields", S3.pass_RegisterFields)
-
- |?> (If.undot,
- "Undot", S3.pass_QmlUndot)
-
- |+> ("CodingDirectives", S3.pass_CodingDirectives)
-
- <?> (If.closure,
- ("EnrichMagic", S3.pass_EnrichMagic),
- ("EnrichMagicPurge", S3.pass_EnrichMagicPurge))
-
- |+> ("SimplifyEquality", S3.pass_SimplifyEquality)
-
- |+> ("SimplifyMagic", S3.pass_SimplifyMagic)
-
- |+> ("JustReorder1", S3.pass_ReorderEnvGen)
-
- |> PH.old_if_handler
- "EarlyLambdaLifting" S2.pass_EarlyLambdaLifting
-
- |+> ("InstrumentForClosureSerialization", S3.pass_InstrumentForClosureSerialization)
-
- (**********************************************)
- (* SLICED PASSES ******************************)
- <?> (If.server or If.separated or If.slicer_test,
- ("Slicing" , S3.pass_SimpleSlicer),
- ("NoSlicing", S3.pass_NoSlicer))
-
- |+> ("Assertion", S3.pass_Assertion)
-
- |?> (PH.neg (If.no_discard_of_unused_stdlib or If.separated),
- "SlicedCleaning", S3.pass_SlicedCleaning)
-
- (* Fun action resolution, step 2/3 *)
- |?> (If.server or If.separated,
- "FunActionEnvSerialize", S3.pass_FunActionEnvSerialize)
-
- (* Explicit instantiation *)
- |?> (If.explicit_instantiation,
- "ExplicitInstantiation", S3.pass_ExplicitInstantiation)
-
- |?> (If.explicit_instantiation,
- "OptimizeExplicitInstantiation", S3.pass_OptimizeExplicitInstantiation)
-
- (* Fun action resolution, step 3/3 *)
- |?> (If.server or If.separated,
- "FunActionJsCallGeneration", S3.pass_FunActionJsCallGeneration)
-
- |+> ("PurgeTypeDirectivesAfterEi", S3.pass_PurgeTypeDirectiveAfterEi)
-
- |?> (If.explicit_instantiation & (If.server or If.separated),
- "ResolveRemoteCalls", S3.pass_ResolveRemoteCalls)
-
- |?> (If.explicit_instantiation,
- "InsertMemoizedTypes", S3.pass_InsertMemoizedTypes)
-
- |+> ("JustReorder2", S3.pass_SlicedReorder)
-
- (* ***********************************************)
- (* FINAL COMPILATION *****************************)
- |+> ("SlicedToFinal", S3.pass_SlicedToFinal)
-
- (* ***********************************************)
- (* FINAL CLIENT COMPILATION **********************)
-
- |?> (If.cps_client,
- "ClientQmlCpsRewriter", S3.pass_ClientCpsRewriter)
+ |> PH.old_if_handler ~if_:If.closure
+ "ServerQmlUncurry" (S2.pass_QmlUncurry2 ~typed:false ~side:`server)
|?> (If.closure,
- "ClientQmlLambdaLifting", S3.pass_ClientLambdaLifting)
-
- |?> (If.constant_sharing_client,
- "QmlClientConstantSharing", S3.pass_ClientQmlConstantSharing)
- (* Insert client code like a js string on server (if
- necessary) - After that client qml code have no more
- place to exist and it dropped *)
- |+> ("JavascriptCompilation", S3.pass_JavascriptCompilation)
-
- |?> (If.server or If.separated,
- "ResolveJsIdent", S3.pass_ResolveJsIdent)
-
- <?> (If.server or If.separated,
- ("GenerateServerAst", S3.pass_GenerateServerAst true),
- ("DontGenerateServerAst", S3.pass_GenerateServerAst false))
-
- (* ***********************************************)
- (* FINAL SERVER COMPILATION **********************)
-
- (* |+> ("CleanLambdaLiftingDirectives", S3.pass_CleanLambdaLiftingDirectives) *)
-
- |?> (If.init & If.server,
- "InitializeBslValues", S3.pass_InitializeBslValues)
-
- |+> ("ServerQmlCpsRewriter", S3.pass_ServerCpsRewriter)
-
- |?| (Switch.back_end, function
- | `qmlflat -> ("QmlFlatCompilation", (PassHandler.make_pass (fun e -> e
-
- |> PH.old_if_handler ~if_:If.closure
- "ServerQmlLambdaLifting" (S2.pass_LambdaLifting2 ~typed:false ~side:`server)
-
- |?> (If.constant_sharing,
- "QmlConstantSharing", S3.pass_QmlConstantSharing)
-
- |> PH.old_if_handler ~if_:If.closure
- "ServerQmlUncurry" (S2.pass_QmlUncurry2 ~typed:false ~side:`server)
+ "ServerQmlClosure", S3.pass_ServerQmlClosure)
- |?> (If.closure,
- "ServerQmlClosure", S3.pass_ServerQmlClosure)
+ |+> ("QmlCompilation", QmlflatPasses.pass_QmlCompilation)
- |+> ("QmlCompilation", S3.pass_QmlCompilation)
+ |+> ("OcamlSplitCode", QmlflatPasses.pass_OcamlSplitCode)
- |+> ("OcamlSplitCode", S3.pass_OcamlSplitCode)
+ |+> ("OcamlGeneration", QmlflatPasses.pass_OcamlGeneration)
- |+> ("OcamlGeneration", S3.pass_OcamlGeneration)
+ |+> ("OcamlCompilation", QmlflatPasses.pass_OcamlCompilation)
- |+> ("OcamlCompilation", S3.pass_OcamlCompilation)
+ )
+ ) (Some Flat_Compiler.dynloader) BslLanguage.ml Flat_Compiler.register_field_name
- )))
- | `qmljs -> ("QmlJsCompilation", (PassHandler.make_pass (fun e -> e
+let js_backend = Compiler.make_backend "qmljs"
+ ~aliases:["node";"js";"nodejs";"node.js"] (
+ PassHandler.make_pass (
+ fun e -> e
- |> PH.old_handler
- "ServerQmlLambdaLifting" (S2.pass_LambdaLifting2 ~typed:false ~side:`server)
+ |> PH.old_handler
+ "ServerQmlLambdaLifting" (S2.pass_LambdaLifting2 ~typed:false ~side:`server)
- |+> ("ServerJavascriptCompilation", S3.pass_ServerJavascriptCompilation)
+ |+> ("ServerJavascriptCompilation", QmljsPasses.pass_ServerJavascriptCompilation)
- |+> ("ServerJavascriptOptimization", S3.pass_ServerJavascriptOptimization)
+ |+> ("ServerJavascriptOptimization", QmljsPasses.pass_ServerJavascriptOptimization)
- |+> ("ServerJavascriptGeneration", S3.pass_ServerJavascriptGeneration)
+ |+> ("ServerJavascriptGeneration", QmljsPasses.pass_ServerJavascriptGeneration)
- )))
- )
- |+> ("CleanUp", S3.pass_CleanUp)
+ )
+ ) None BslLanguage.nodejs ignore
- |+> ("ByeBye", S3.pass_ByeBye)
+let backend_handlers = [js_backend; flat_backend]
- |> PH.return )) (* end of the pass endOfSeparateCompilation *)
- |> PH.return )) (* end of the pass loadObjects *)
- |> PH.return
+let () = Compiler.compile(backend_handlers)
let () = OManager.exit 0
View
10 compiler/opa/pass_BslLoading.ml
@@ -300,6 +300,7 @@ let find_used_plugins bypass_map code =
used_plugins_names
let process
+ backend_dynloader_switcher
~options
~code
=
@@ -488,9 +489,12 @@ let process
let module M = (val client_back_end : Qml2jsOptions.JsBackend) in
(M.dynloader, BslLanguage.js) in
let server_back_end_dynload, server_bsl_lang =
- match server_back_end with
- | `qmlflat -> (Flat_Compiler.dynloader, BslLanguage.ml)
- | `qmljs -> (client_back_end_dynload, BslLanguage.nodejs)
+ match backend_dynloader_switcher server_back_end with
+ | (Some dynload), lg -> (dynload, lg)
+ | None, lg -> (client_back_end_dynload, lg)
+ (* match server_back_end with *)
+ (* | OpaEnv.Backend "qmljs" -> (client_back_end_dynload, BslLanguage.nodejs) *)
+ (* | _ -> (Flat_Compiler.dynloader, BslLanguage.ml) *)
in
(* Register plug-ins with actual backend.*)
List.iter
View
3  compiler/opa/pass_BslLoading.mli
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of Opa.
@@ -48,6 +48,7 @@
*)
val process :
+ (OpaEnv.opa_back_end -> ((BslPluginInterface.plugin -> unit) option * BslLanguage.t)) ->
options: OpaEnv.opa_options ->
code:(((_, _) SurfaceAst.code_elt ObjectFiles.parsed_code) as 'code) ->
OpaEnv.opa_options * 'code * BslLib.env_bsl
View
18 compiler/opa/passes.ml
@@ -315,8 +315,8 @@ let pass_simple_slicer ~(options:opa_options) (env:'tmp_env env_Gen) =
in
let client_bsl_lang = BslLanguage.js in
let server_bsl_lang = match options.OpaEnv.back_end with
- | `qmlflat -> BslLanguage.ml
- | `qmljs -> BslLanguage.nodejs
+ | OpaEnv.Backend "qmljs" -> BslLanguage.nodejs
+ | _ -> BslLanguage.ml
in
let stdlib_gamma, typer_env, client, server =
QmlSimpleSlicer.process_code
@@ -553,18 +553,18 @@ let pass_QmlCpsRewriter client ~(options:opa_options) (env:env_NewFinalCompile)
let opaoptions = options in
let qml_closure =
match options.OpaEnv.back_end with
- | `qmljs -> false
- | `qmlflat -> options.OpaEnv.closure
+ | OpaEnv.Backend "qmljs" -> false
+ | _ -> options.OpaEnv.closure
in
let server_side =
match options.OpaEnv.back_end with
- | `qmljs -> false
- | `qmlflat -> not client;
+ | OpaEnv.Backend "qmljs" -> false
+ | _ -> not client;
in
let lang =
match options.OpaEnv.back_end with
- | `qmljs -> BslLanguage.nodejs
- | `qmlflat -> BslLanguage.ml
+ | OpaEnv.Backend "qmljs" -> BslLanguage.nodejs
+ | _ -> BslLanguage.ml
in
let options =
{ QmlCpsRewriter.default_options with QmlCpsRewriter.
@@ -694,7 +694,7 @@ let pass_QmlCompiler ~(options:opa_options) (env:env_NewFinalCompile) : env_Bina
let env_bsl = env.newFinalCompile_bsl in
let argv_options = pass_OpaOptionsToQmlOptions ~options qml_milkshake in
(** Choice of back-end *)
- assert (`qmlflat = options.OpaEnv.back_end);
+ assert (OpaEnv.Backend "qmlflat" = options.OpaEnv.back_end);
let qml_to_ocaml = Flat_Compiler.qml_to_ocaml in
(* This pass is splitten in 3 in opas3 *)
let return = Qml2ocaml.Sugar.for_opa qml_to_ocaml argv_options env_bsl qml_milkshake in
View
250 compiler/opa/qmlflat.ml
@@ -0,0 +1,250 @@
+(* extractors *)
+let extract_final_ac env =
+ env.P.newFinalCompile_qml_milkshake.QmlBlender.env.QmlTypes.annotmap,
+ env.P.newFinalCompile_qml_milkshake.QmlBlender.code
+let extract_final_gamma env =
+ env.P.newFinalCompile_qml_milkshake.QmlBlender.env.QmlTypes.gamma
+let extract_final_code env = env.P.newFinalCompile_qml_milkshake.QmlBlender.code
+let extract_final_bypass_typer env = env.P.newFinalCompile_qml_milkshake.QmlBlender.env.QmlTypes.bypass_typer
+let extract pass_env = (extract_final_bypass_typer pass_env, extract_final_code pass_env)
+
+let pass_QmlLiftDeepRecords =
+ make_process_code_pass
+ (fun _ -> Pass_LiftDeepRecords.process_code ~typed:true)
+ P.extract_env_NewFinalCompile
+ P.rebuild_env_NewFinalCompile
+ ()
+
+let pass_InitializeBslValues =
+ PH.make_pass
+ (fun e ->
+ let env = e.PH.env in
+ let annotmap, code = extract_final_ac env in
+ let gamma = extract_final_gamma env in
+ let stdlib_gamma = env.P.newFinalCompile_stdlib_gamma in
+ let gamma, annotmap, code =
+ Pass_InitializeBslValues.process_code ~stdlib_gamma gamma annotmap code
+ in
+ let milkshake = { QmlBlender.
+ code = code;
+ env = {env.P.newFinalCompile_qml_milkshake.QmlBlender.env with QmlTypes.
+ annotmap = annotmap;
+ gamma = gamma;
+ }
+ } in
+ let env = {env with P.newFinalCompile_qml_milkshake = milkshake} in
+ {e with PH.env = env}
+ )
+
+let pass_ServerCpsRewriter =
+ let transform pass_env =
+ let options = pass_env.PassHandler.options in
+ let env = pass_env.PassHandler.env in
+ { pass_env with PassHandler.
+ env = Passes.pass_QmlCpsRewriter false ~options env
+ }
+ in
+ (* invariants, and pre/post conds *)
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ ] in
+ let postcond =
+ [
+ (*
+ This post condition is currently broken because of the second_order bypasses.
+ In bsl_ocaml_init.ml they take 1 extra argument, but the bypass_typer does not know
+ about it. This condition is desactivated until we solve this probleme.
+ QmlCheck.Bypass.applied extract
+ *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
+
+let pass_ServerQmlClosure =
+ PassHandler.make_pass
+ (fun e ->
+ { e with PH.env = P.pass_QmlClosure2 ~typed:false ~side:`server ~options:e.PH.options e.PH.env })
+
+let pass_QmlConstantSharing_gen side =
+ let transform pass_env =
+ let typerEnv, code = P.extract_env_NewFinalCompile pass_env.PH.env in
+ let gamma = typerEnv.QmlTypes.gamma
+ and annotmap = typerEnv.QmlTypes.annotmap in
+ let (gamma,annotmap), code =
+ Pass_ConstantSharing.process_code ~side ~typed:false gamma annotmap code in
+ let typerEnv =
+ { typerEnv with
+ QmlTypes.gamma = gamma;
+ QmlTypes.annotmap = annotmap }
+ in
+ { pass_env with PH.env = P.rebuild_env_NewFinalCompile pass_env.PH.env typerEnv code
+ }
+ in
+ let precond =
+ [
+ (* TODO: add pre condition *)
+ ] in
+ let postcond =
+ [
+ QmlAlphaConv.Check.alpha extract_final_ac ;
+ ] in
+ PassHandler.make_pass ~precond ~postcond transform
+
+let pass_QmlConstantSharing =
+ pass_QmlConstantSharing_gen `server
+let pass_ClientQmlConstantSharing =
+ let pass_QmlConstantSharing = pass_QmlConstantSharing_gen `client in
+ Adapter.adapt_new_sliced_on_client pass_QmlConstantSharing
+
+let pass_QmlCompilation =
+ let transform pass_env =
+ let options = pass_env.PH.options in
+ let env = pass_env.PH.env in
+ (* get env entities *)
+ let qml2ocaml_env_bsl = env.Passes.newFinalCompile_bsl in
+ let qml2ocaml_qml_milkshake = env.Passes.newFinalCompile_qml_milkshake in
+ (* renaming is not used *)
+ (* 1) transform options *)
+ let qmlCompilation_options = Passes.pass_OpaOptionsToQmlOptions ~options qml2ocaml_qml_milkshake in
+ (* 2) selection of the back-end *)
+ assert (options.O.back_end = OpaEnv.Backend "qmlflat");
+ let qml_to_ocaml =Flat_Compiler.qml_to_ocaml in
+ (* proceed *)
+ let qmlCompilation_env_ocaml_input = qml_to_ocaml qmlCompilation_options qml2ocaml_env_bsl qml2ocaml_qml_milkshake in
+ (* build env *)
+ let qmlCompilation_env =
+ {
+ qmlCompilation_options = qmlCompilation_options ;
+ qmlCompilation_env_ocaml_input = qmlCompilation_env_ocaml_input
+ }
+ in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = qmlCompilation_env ;
+ printers = OcamlTrack.printers (fun env -> env.qmlCompilation_env_ocaml_input.Qml2ocaml.ocaml_code) ;
+ trackers = empty
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
+
+let pass_OcamlSplitCode =
+ let transform pass_env =
+ let env = pass_env.PassHandler.env in
+ (* get env entities *)
+ let ocamlSplitCode_options = env.qmlCompilation_options in
+ let qmlCompilation_env_ocaml_input = env.qmlCompilation_env_ocaml_input in
+ (* proceed *)
+ let ocamlSplitCode_env_ocaml_split =
+ Qml2ocaml.OcamlCompilation.ocaml_split_code ocamlSplitCode_options qmlCompilation_env_ocaml_input in
+ (* build env *)
+ let env = {
+ ocamlSplitCode_options = ocamlSplitCode_options ;
+ ocamlSplitCode_env_ocaml_split = ocamlSplitCode_env_ocaml_split ;
+ }
+ in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = env ;
+ printers = empty ;
+ trackers = empty
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
+
+let pass_OcamlGeneration =
+ let transform pass_env =
+ let env = pass_env.PassHandler.env in
+ (* get env entities *)
+ let ocamlGeneration_options = env.ocamlSplitCode_options in
+ let ocamlSplitCode_env_ocaml_split = env.ocamlSplitCode_env_ocaml_split in
+ (* proceed *)
+ let ocamlGeneration_env_ocaml_output =
+ Qml2ocaml.OcamlCompilation.ocaml_generation ocamlGeneration_options ocamlSplitCode_env_ocaml_split in
+ (* build env *)
+ let ocamlGeneration_env =
+ {
+ ocamlGeneration_options = ocamlGeneration_options ;
+ ocamlGeneration_env_ocaml_output = ocamlGeneration_env_ocaml_output
+ }
+ in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = ocamlGeneration_env ;
+ printers = empty ;
+ trackers = empty
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
+
+let pass_OcamlCompilation =
+ let transform pass_env =
+ let env = pass_env.PassHandler.env in
+ (* get env entities *)
+ let ocamlGeneration_options = env.ocamlGeneration_options in
+ let ocamlGeneration_env_ocaml_output = env.ocamlGeneration_env_ocaml_output in
+ (* proceed *)
+ let ocamlCompilation_returned_code =
+ Qml2ocaml.OcamlCompilation.ocaml_compilation ocamlGeneration_options ocamlGeneration_env_ocaml_output in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = ocamlCompilation_returned_code ;
+ printers = empty ;
+ trackers = empty ;
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
View
189 compiler/opa/qmlflatPasses.ml
@@ -0,0 +1,189 @@
+(*
+ Copyright © 2011, 2012 MLstate
+
+ This file is part of Opa.
+
+ Opa is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ Opa is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with Opa. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+module O = OpaEnv
+module P = Passes
+module PH = PassHandler
+
+type env_QmlCompilation = {
+ qmlCompilation_options : Qml2ocamlOptions.argv_options ;
+ qmlCompilation_env_ocaml_input : Qml2ocaml.env_ocaml_input ;
+}
+
+type env_OcamlSplitCode = {
+ ocamlSplitCode_options : Qml2ocamlOptions.argv_options ;
+ ocamlSplitCode_env_ocaml_split : Qml2ocaml.env_ocaml_split ;
+}
+
+type env_OcamlGeneration = {
+ ocamlGeneration_options : Qml2ocamlOptions.argv_options ;
+ ocamlGeneration_env_ocaml_output : Qml2ocaml.env_ocaml_output ;
+}
+
+type env_OcamlCompilation = {
+ ocamlCompilation_returned_code : int ;
+}
+
+let pass_QmlCompilation =
+ let transform pass_env =
+ let options = pass_env.PH.options in
+ let env = pass_env.PH.env in
+ (* get env entities *)
+ let qml2ocaml_env_bsl = env.Passes.newFinalCompile_bsl in
+ let qml2ocaml_qml_milkshake = env.Passes.newFinalCompile_qml_milkshake in
+ (* renaming is not used *)
+ (* 1) transform options *)
+ let qmlCompilation_options = Passes.pass_OpaOptionsToQmlOptions ~options qml2ocaml_qml_milkshake in
+ (* 2) selection of the back-end *)
+ let qml_to_ocaml = Flat_Compiler.qml_to_ocaml in
+ (* proceed *)
+ let qmlCompilation_env_ocaml_input = qml_to_ocaml qmlCompilation_options qml2ocaml_env_bsl qml2ocaml_qml_milkshake in
+ (* build env *)
+ let qmlCompilation_env =
+ {
+ qmlCompilation_options = qmlCompilation_options ;
+ qmlCompilation_env_ocaml_input = qmlCompilation_env_ocaml_input
+ }
+ in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = qmlCompilation_env ;
+ printers = OcamlTrack.printers (fun env -> env.qmlCompilation_env_ocaml_input.Qml2ocaml.ocaml_code) ;
+ trackers = empty
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
+
+let pass_OcamlSplitCode =
+ let transform pass_env =
+ let env = pass_env.PassHandler.env in
+ (* get env entities *)
+ let ocamlSplitCode_options = env.qmlCompilation_options in
+ let qmlCompilation_env_ocaml_input = env.qmlCompilation_env_ocaml_input in
+ (* proceed *)
+ let ocamlSplitCode_env_ocaml_split =
+ Qml2ocaml.OcamlCompilation.ocaml_split_code ocamlSplitCode_options qmlCompilation_env_ocaml_input in
+ (* build env *)
+ let env = {
+ ocamlSplitCode_options = ocamlSplitCode_options ;
+ ocamlSplitCode_env_ocaml_split = ocamlSplitCode_env_ocaml_split ;
+ }
+ in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = env ;
+ printers = empty ;
+ trackers = empty
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
+
+let pass_OcamlGeneration =
+ let transform pass_env =
+ let env = pass_env.PassHandler.env in
+ (* get env entities *)
+ let ocamlGeneration_options = env.ocamlSplitCode_options in
+ let ocamlSplitCode_env_ocaml_split = env.ocamlSplitCode_env_ocaml_split in
+ (* proceed *)
+ let ocamlGeneration_env_ocaml_output =
+ Qml2ocaml.OcamlCompilation.ocaml_generation ocamlGeneration_options ocamlSplitCode_env_ocaml_split in
+ (* build env *)
+ let ocamlGeneration_env =
+ {
+ ocamlGeneration_options = ocamlGeneration_options ;
+ ocamlGeneration_env_ocaml_output = ocamlGeneration_env_ocaml_output
+ }
+ in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = ocamlGeneration_env ;
+ printers = empty ;
+ trackers = empty
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
+
+let pass_OcamlCompilation =
+ let transform pass_env =
+ let env = pass_env.PassHandler.env in
+ (* get env entities *)
+ let ocamlGeneration_options = env.ocamlGeneration_options in
+ let ocamlGeneration_env_ocaml_output = env.ocamlGeneration_env_ocaml_output in
+ (* proceed *)
+ let ocamlCompilation_returned_code =
+ Qml2ocaml.OcamlCompilation.ocaml_compilation ocamlGeneration_options ocamlGeneration_env_ocaml_output in
+ let empty _ = [] in
+ {
+ pass_env with PassHandler.
+ env = ocamlCompilation_returned_code ;
+ printers = empty ;
+ trackers = empty ;
+ }
+ in
+ let invariant =
+ [
+ (* TODO: add invariants *)
+ ] in
+ let precond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ let postcond =
+ [
+ (* TODO: add pre conditions *)
+ ] in
+ PassHandler.make_pass ~invariant ~precond ~postcond transform
View
64 compiler/opa/qmlflatPasses.mli
@@ -0,0 +1,64 @@
+(*
+ Copyright © 2011, 2012 MLstate
+
+ This file is part of Opa.
+
+ Opa is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ Opa is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with Opa. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+(* FINAL QMLFLAT COMPILATION *********************)
+
+(**
+ Environment returned by the QmlCompilation.
+*)
+type env_QmlCompilation = {
+ qmlCompilation_options : Qml2ocamlOptions.argv_options ;
+ qmlCompilation_env_ocaml_input : Qml2ocaml.env_ocaml_input ;
+}
+
+(**
+ Environment returned after splitting ocaml code into smaller files
+*)
+type env_OcamlSplitCode = {
+ ocamlSplitCode_options : Qml2ocamlOptions.argv_options ;
+ ocamlSplitCode_env_ocaml_split : Qml2ocaml.env_ocaml_split ;
+}
+
+(**
+ Environment returned by the OcamlGeneration.
+*)
+type env_OcamlGeneration = {
+ ocamlGeneration_options : Qml2ocamlOptions.argv_options ;
+ ocamlGeneration_env_ocaml_output : Qml2ocaml.env_ocaml_output ;
+}
+
+(**
+ Environment returned by the OcamlCompilation.
+*)
+type env_OcamlCompilation = {
+ ocamlCompilation_returned_code : int ;
+}
+
+val pass_QmlCompilation :
+ (Passes.env_NewFinalCompile, env_QmlCompilation) S3Passes.opa_pass
+
+val pass_OcamlSplitCode :
+ (env_QmlCompilation, env_OcamlSplitCode) S3Passes.opa_pass
+
+val pass_OcamlGeneration :
+ (env_OcamlSplitCode, env_OcamlGeneration) S3Passes.opa_pass
+
+val pass_OcamlCompilation :
+ (env_OcamlGeneration, int) S3Passes.opa_pass
+
+(* ***********************************************)
View
157 compiler/opa/qmljsPasses.ml
@@ -0,0 +1,157 @@
+(*
+ Copyright © 2011, 2012 MLstate
+
+ This file is part of Opa.
+
+ Opa is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ Opa is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with Opa. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+module P = Passes
+module PH = PassHandler
+
+module List = BaseList
+
+type env_JsCompilation = {
+ env_js_input : Qml2jsOptions.env_js_input;
+ jsoptions : Qml2jsOptions.t;
+ env_bsl : BslLib.env_bsl;
+ loaded_bsl : Qml2js.loaded_bsl;
+ is_distant : JsIdent.t -> bool;
+}
+
+let pass_ServerJavascriptCompilation =
+ PassHandler.make_pass
+ (fun e ->
+ let options = e.PH.options in
+ let env = e.PH.env in
+ let module JsBackend = (val (options.OpaEnv.js_back_end) : Qml2jsOptions.JsBackend) in
+ let compilation_directory =
+ match ObjectFiles.compilation_mode () with
+ | `compilation -> Option.get (ObjectFiles.get_compilation_directory ())
+ | `init | `linking -> "_build"
+ | `prelude -> assert false
+ in
+ let jsoptions =
+ let argv_options = Qml2jsOptions.Argv.default () in
+ { argv_options with Qml2jsOptions.
+ cps = options.OpaEnv.cps;
+ cps_toplevel_concurrency = options.OpaEnv.cps_toplevel_concurrency ;
+ qml_closure = options.OpaEnv.closure;
+ extra_lib = options.OpaEnv.extrajs;
+ alpha_renaming = options.OpaEnv.js_local_renaming;
+ check_bsl_types = options.OpaEnv.js_check_bsl_types;
+ cleanup = options.OpaEnv.js_cleanup;
+ inlining = options.OpaEnv.js_local_inlining;
+ global_inlining = options.OpaEnv.js_global_inlining;
+ no_assert = options.OpaEnv.no_assert;
+ target = options.OpaEnv.target;
+ compilation_directory;
+ static_link = options.OpaEnv.static_link;
+ package_version = options.OpaEnv.package_version;
+ modular_plugins = options.OpaEnv.modular_plugins;
+ lang = `node;
+ } in
+ let jsoptions =
+ match options.OpaEnv.run_server_options with
+ | None -> jsoptions
+ | Some exe_argv ->
+ { jsoptions with Qml2jsOptions. exe_argv; exe_run = true }
+ in
+ let env_bsl = env.Passes.newFinalCompile_bsl in
+ let loaded_bsl =
+ Qml2js.JsTreat.js_bslfilesloading jsoptions env_bsl in
+ let is_distant, renaming =
+ let other = env.P.newFinalCompile_renaming_client in
+ let here = env.P.newFinalCompile_renaming_server in
+ S3Passes.EnvUtils.jsutils_from_renamings ~here ~other
+ in
+ let exported = env.Passes.newFinalCompile_exported in
+ let env_js_input = JsBackend.compile
+ ~runtime_ast:false
+ ~bsl:loaded_bsl.Qml2js.generated_ast
+ ~val_:OpaMapToIdent.val_
+ ~closure_map:env.Passes.newFinalCompile_closure_map
+ ~is_distant
+ ~renaming
+ ~bsl_lang:BslLanguage.nodejs
+ ~exported
+ jsoptions
+ env_bsl
+ env.Passes.newFinalCompile_qml_milkshake.QmlBlender.env
+ env.Passes.newFinalCompile_qml_milkshake.QmlBlender.code
+ in
+ let is_distant ident =
+ match ident with
+ | JsIdent.ExprIdent i ->
+ (try
+ ignore
+ (QmlRenamingMap.new_from_original
+ env.P.newFinalCompile_renaming_client
+ i);
+ true
+ with Not_found -> false)
+ | _ -> false
+ in
+ PH.make_env options {
+ env_js_input;
+ jsoptions;
+ env_bsl;
+ loaded_bsl;
+ is_distant;
+ }
+ )
+
+let pass_ServerJavascriptOptimization =
+ PassHandler.make_pass
+ (fun e ->
+ let env = e.PH.env in
+ let exported = env.env_js_input.Qml2jsOptions.exported in
+ let is_exported i = JsIdentSet.mem i exported || env.is_distant i in
+ let js_code =
+ Pass_ServerJavascriptOptimization.process_code
+ is_exported
+ env.env_js_input.Qml2jsOptions.js_code
+ in
+ let js_init_contents =
+ List.map
+ (fun (x, c) -> x,
+ match c with
+ | `string _ -> assert false
+ | `ast proj -> `ast
+ (List.map
+ (fun (i, e) ->
+ (i, Pass_ServerJavascriptOptimization.process_code_elt
+ is_exported e))
+ proj)
+ ) env.env_js_input.Qml2jsOptions.js_init_contents
+ in
+ PH.make_env e.PH.options
+ { env with env_js_input =
+ { env.env_js_input with Qml2jsOptions. js_code; js_init_contents }
+ }
+ )
+
+let pass_ServerJavascriptGeneration =
+ PassHandler.make_pass
+ (fun e ->
+ let env = e.PH.env in
+ let jsoptions = env.jsoptions in
+ let env_bsl = env.env_bsl in
+ let loaded_bsl = env.loaded_bsl in
+ let env_js_output =
+ Qml2js.JsTreat.js_generation jsoptions env_bsl
+ loaded_bsl env.env_js_input
+ in
+ let code = Qml2js.JsTreat.js_treat jsoptions env_js_output in
+ PH.make_env e.PH.options code
+ )
View
33 compiler/opa/qmljsPasses.mli
@@ -0,0 +1,33 @@
+(*
+ Copyright © 2011, 2012 MLstate
+
+ This file is part of Opa.
+
+ Opa is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ Opa is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with Opa. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+(* FINAL QMLJS COMPILATION ***********************)
+
+(** Environment needed by the final JavasScript compilation. *)
+type env_JsCompilation
+
+val pass_ServerJavascriptCompilation :
+ (Passes.env_NewFinalCompile, env_JsCompilation) S3Passes.opa_pass
+
+val pass_ServerJavascriptOptimization :
+ (env_JsCompilation, env_JsCompilation) S3Passes.opa_pass
+
+val pass_ServerJavascriptGeneration :
+ (env_JsCompilation, int) S3Passes.opa_pass
+
+(* ***********************************************)
View
352 compiler/opa/s3Passes.ml
@@ -15,6 +15,7 @@
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
+
(* shorthands *)
module O = OpaEnv
module P = Passes
@@ -36,25 +37,6 @@ type ('env, 'env2) opa_old_pass =
type env_bothFinalCompile = (Passes.env_NewFinalCompile * Passes.env_NewFinalCompile)
-type env_QmlCompilation = {
- qmlCompilation_options : Qml2ocamlOptions.argv_options ;
- qmlCompilation_env_ocaml_input : Qml2ocaml.env_ocaml_input ;
-}
-
-type env_OcamlSplitCode = {
- ocamlSplitCode_options : Qml2ocamlOptions.argv_options ;
- ocamlSplitCode_env_ocaml_split : Qml2ocaml.env_ocaml_split ;
-}
-
-type env_OcamlGeneration = {
- ocamlGeneration_options : Qml2ocamlOptions.argv_options ;
- ocamlGeneration_env_ocaml_output : Qml2ocaml.env_ocaml_output ;
-}
-
-type env_OcamlCompilation = {
- ocamlCompilation_returned_code : int ;
-}
-
(* when propagating to all environment is overkill
ensures that their is no package mismatch, and no mutability of extra env *)
let pass_extra_output_env (default:'extra_env option) =
@@ -345,11 +327,11 @@ end = struct
end
-(** Select the good register function according to back-end *)
-let register_fields options =
- match options.O.back_end with
- | `qmlflat -> Flat_Compiler.register_field_name
- | _ -> (fun _ -> ())
+(* (\** Select the good register function according to back-end *\) *)
+(* let register_fields options = *)
+(* match options.O.back_end with *)
+(* | OpaEnv.Backend "qmlflat" -> *)
+(* | _ -> (fun _ -> ()) *)
(**********************************************************)
@@ -359,17 +341,17 @@ let register_fields options =
(* AND COMPLETE MLI ***************************************)
(**********************************************************)
-let pass_Welcome =
+let pass_Welcome backend_options =
PassHandler.make_pass
(fun {PH.env=()} ->
- OpaEnv.Options.parse_options ();
+ OpaEnv.Options.parse_options backend_options;
let options = OpaEnv.Options.get_options () in
OManager.verbose "Opa version %s" BuildInfos.opa_version_name ;
OManager.verbose "(c) 2007-%s MLstate, All Rights Reserved." BuildInfos.year;
OManager.verbose "Build: %s" BuildInfos.version_id;
PassHandler.make_env options ())
-let pass_CheckOptions =
+let pass_CheckOptions unify_backend_name =
PassHandler.make_pass
(fun e ->
if List.is_empty e.PH.options.O.filenames
@@ -381,7 +363,8 @@ let pass_CheckOptions =
exit 1;
) else (
let filenames = e.PH.options.O.filenames in
- PassHandler.make_env e.PH.options filenames
+ let back_end = unify_backend_name e.PH.options.O.back_end in
+ PassHandler.make_env { e.PH.options with O.back_end = back_end } filenames
)
)
@@ -552,13 +535,13 @@ let pass_DbEngineImportation =
e
)
-let pass_BslLoading =
+let pass_BslLoading backend_dynloader_switcher =
PassHandler.make_pass
(fun e ->
let options = e.PH.options in
let env = e.PH.env in
let options, env, env_bsl =
- Pass_BslLoading.process ~options ~code:env
+ Pass_BslLoading.process backend_dynloader_switcher ~options ~code:env
in
PassHandler.make_env options (env, env_bsl)
)
@@ -873,7 +856,7 @@ let pass_FunActionLifting =
} })
-let pass_TypesDefinitions =
+let pass_TypesDefinitions register_fields =
let precond =
[
(* TODO: add precondition *)
@@ -895,7 +878,7 @@ let pass_TypesDefinitions =
let typerEnv = env.Passes.typerEnv in
let code = env.Passes.qmlAst in
let local_typedefs, typerEnv, code, stdlib_gamma = Pass_TypeDefinition.process_code
- (register_fields e.PH.options) typerEnv code in
+ (register_fields e.PH.options.O.back_end) typerEnv code in
let env = { env with Passes.typerEnv; local_typedefs; stdlib_gamma; qmlAst = code; } in
{ e with PH.env = env }
)
@@ -1131,10 +1114,10 @@ let pass_BypassHoisting =
)
~invariant ()
-let pass_RegisterFields =
+let pass_RegisterFields register_fields =
PassHandler.make_pass
(fun e ->
- Pass_RegisterFields.perform (register_fields e.PH.options) e.PH.env.P.qmlAst;
+ Pass_RegisterFields.perform (register_fields e.PH.options.O.back_end) e.PH.env.P.qmlAst;
e
)
~invariant
@@ -1396,7 +1379,7 @@ let pass_InsertMemoizedTypes =
in
Pass_ExplicitInstantiation.finalize_memoized_defintions
- (e.PH.options.O.back_end <> `qmlflat);
+ (e.PH.options.O.back_end <> OpaEnv.Backend "qmlflat");
let server_code = List.tail_append new_server_code server_code in
let client_code = List.tail_append new_client_code client_code in
let env_gen =
@@ -1589,7 +1572,7 @@ let pass_ExplicitInstantiation =
(* desactivated for flat because breaks OCaml compilation
TODO : Fix it *)
Pass_ExplicitInstantiation.init_memoized_definitions
- (e.PH.options.O.back_end <> `qmlflat);
+ (e.PH.options.O.back_end <> OpaEnv.Backend "qmlflat");
(* TODO: optimize by adding only dummy arguments for published functions,
if there is no explicit instantiation to be done there;
@@ -2021,11 +2004,6 @@ let pass_ServerCpsRewriter =
] in
PassHandler.make_pass ~invariant ~precond ~postcond transform
-let pass_ServerQmlClosure =
- PassHandler.make_pass
- (fun e ->
- { e with PH.env = P.pass_QmlClosure2 ~typed:false ~side:`server ~options:e.PH.options e.PH.env })
-
let pass_QmlConstantSharing_gen side =
let transform pass_env =
let typerEnv, code = P.extract_env_NewFinalCompile pass_env.PH.env in
@@ -2057,295 +2035,10 @@ let pass_ClientQmlConstantSharing =
let pass_QmlConstantSharing = pass_QmlConstantSharing_gen `client in
Adapter.adapt_new_sliced_on_client pass_QmlConstantSharing
-let pass_QmlCompilation =
- let transform pass_env =
- let options = pass_env.PH.options in
- let env = pass_env.PH.env in
- (* get env entities *)
- let qml2ocaml_env_bsl = env.Passes.newFinalCompile_bsl in
- let qml2ocaml_qml_milkshake = env.Passes.newFinalCompile_qml_milkshake in
- (* renaming is not used *)
- (* 1) transform options *)
- let qmlCompilation_options = Passes.pass_OpaOptionsToQmlOptions ~options qml2ocaml_qml_milkshake in
- (* 2) selection of the back-end *)
- assert (options.O.back_end = `qmlflat);
- let qml_to_ocaml =Flat_Compiler.qml_to_ocaml in
- (* proceed *)
- let qmlCompilation_env_ocaml_input = qml_to_ocaml qmlCompilation_options qml2ocaml_env_bsl qml2ocaml_qml_milkshake in
- (* build env *)
- let qmlCompilation_env =
- {
- qmlCompilation_options = qmlCompilation_options ;
- qmlCompilation_env_ocaml_input = qmlCompilation_env_ocaml_input
- }
- in
- let empty _ = [] in
- {
- pass_env with PassHandler.
- env = qmlCompilation_env ;
- printers = OcamlTrack.printers (fun env -> env.qmlCompilation_env_ocaml_input.Qml2ocaml.ocaml_code) ;
- trackers = empty
- }
- in
- let invariant =
- [
- (* TODO: add invariants *)
- ] in
- let precond =
- [
- (* TODO: add pre conditions *)
- ] in
- let postcond =
- [
- (* TODO: add pre conditions *)
- ] in
- PassHandler.make_pass ~invariant ~precond ~postcond transform
-
-let pass_OcamlSplitCode =
- let transform pass_env =
- let env = pass_env.PassHandler.env in
- (* get env entities *)
- let ocamlSplitCode_options = env.qmlCompilation_options in
- let qmlCompilation_env_ocaml_input = env.qmlCompilation_env_ocaml_input in
- (* proceed *)
- let ocamlSplitCode_env_ocaml_split =
- Qml2ocaml.OcamlCompilation.ocaml_split_code ocamlSplitCode_options qmlCompilation_env_ocaml_input in
- (* build env *)
- let env = {
- ocamlSplitCode_options = ocamlSplitCode_options ;
- ocamlSplitCode_env_ocaml_split = ocamlSplitCode_env_ocaml_split ;
- }
- in
- let empty _ = [] in
- {
- pass_env with PassHandler.
- env = env ;
- printers = empty ;
- trackers = empty
- }
- in
- let invariant =
- [
- (* TODO: add invariants *)
- ] in
- let precond =
- [
- (* TODO: add pre conditions *)
- ] in
- let postcond =
- [
- (* TODO: add pre conditions *)
- ] in
- PassHandler.make_pass ~invariant ~precond ~postcond transform
-
-let pass_OcamlGeneration =
- let transform pass_env =
- let env = pass_env.PassHandler.env in
- (* get env entities *)
- let ocamlGeneration_options = env.ocamlSplitCode_options in
- let ocamlSplitCode_env_ocaml_split = env.ocamlSplitCode_env_ocaml_split in
- (* proceed *)
- let ocamlGeneration_env_ocaml_output =
- Qml2ocaml.OcamlCompilation.ocaml_generation ocamlGeneration_options ocamlSplitCode_env_ocaml_split in
- (* build env *)
- let ocamlGeneration_env =
- {
- ocamlGeneration_options = ocamlGeneration_options ;
- ocamlGeneration_env_ocaml_output = ocamlGeneration_env_ocaml_output
- }
- in
- let empty _ = [] in
- {
- pass_env with PassHandler.
- env = ocamlGeneration_env ;
- printers = empty ;
- trackers = empty
- }
- in
- let invariant =
- [
- (* TODO: add invariants *)
- ] in
- let precond =
- [
- (* TODO: add pre conditions *)
- ] in
- let postcond =
- [
- (* TODO: add pre conditions *)
- ] in
- PassHandler.make_pass ~invariant ~precond ~postcond transform
-
-let pass_OcamlCompilation =
- let transform pass_env =
- let env = pass_env.PassHandler.env in
- (* get env entities *)
- let ocamlGeneration_options = env.ocamlGeneration_options in
- let ocamlGeneration_env_ocaml_output = env.ocamlGeneration_env_ocaml_output in
- (* proceed *)
- let ocamlCompilation_returned_code =
- Qml2ocaml.OcamlCompilation.ocaml_compilation ocamlGeneration_options ocamlGeneration_env_ocaml_output in
- let empty _ = [] in
- {
- pass_env with PassHandler.
- env = ocamlCompilation_returned_code ;
- printers = empty ;
- trackers = empty ;
- }
- in
- let invariant =
- [
- (* TODO: add invariants *)
- ] in
- let precond =
- [
- (* TODO: add pre conditions *)
- ] in
- let postcond =
- [
- (* TODO: add pre conditions *)
- ] in
- PassHandler.make_pass ~invariant ~precond ~postcond transform
-
-
-(* ***********************************************)
-(* FINAL QMLJS COMPILATION ***********************)
-
-type env_JsCompilation = {
- env_js_input : Qml2jsOptions.env_js_input;
- jsoptions : Qml2jsOptions.t;
- env_bsl : BslLib.env_bsl;
- loaded_bsl : Qml2js.loaded_bsl;
- is_distant : JsIdent.t -> bool;
-}
-
-let pass_ServerJavascriptCompilation =
- PassHandler.make_pass
- (fun e ->
- let options = e.PH.options in
- let env = e.PH.env in
- assert (options.OpaEnv.back_end == `qmljs);
- let module JsBackend = (val (options.OpaEnv.js_back_end) : Qml2jsOptions.JsBackend) in
- let compilation_directory =
- match ObjectFiles.compilation_mode () with
- | `compilation -> Option.get (ObjectFiles.get_compilation_directory ())
- | `init | `linking -> "_build"
- | `prelude -> assert false
- in
- let jsoptions =
- let argv_options = Qml2jsOptions.Argv.default () in
- { argv_options with Qml2jsOptions.
- cps = options.OpaEnv.cps;
- cps_toplevel_concurrency = options.OpaEnv.cps_toplevel_concurrency ;
- qml_closure = options.OpaEnv.closure;
- extra_lib = options.OpaEnv.extrajs;
- alpha_renaming = options.OpaEnv.js_local_renaming;
- check_bsl_types = options.OpaEnv.js_check_bsl_types;
- cleanup = options.OpaEnv.js_cleanup;
- inlining = options.OpaEnv.js_local_inlining;
- global_inlining = options.OpaEnv.js_global_inlining;
- no_assert = options.OpaEnv.no_assert;
- target = options.OpaEnv.target;
- compilation_directory;
- static_link = options.OpaEnv.static_link;
- package_version = options.OpaEnv.package_version;
- modular_plugins = options.OpaEnv.modular_plugins;
- lang = `node;
- } in
- let jsoptions =
- match options.OpaEnv.run_server_options with
- | None -> jsoptions
- | Some exe_argv ->
- { jsoptions with Qml2jsOptions. exe_argv; exe_run = true }
- in
- let env_bsl = env.Passes.newFinalCompile_bsl in
- let loaded_bsl =
- Qml2js.JsTreat.js_bslfilesloading jsoptions env_bsl in
- let is_distant, renaming =
- let other = env.P.newFinalCompile_renaming_client in
- let here = env.P.newFinalCompile_renaming_server in
- EnvUtils.jsutils_from_renamings ~here ~other
- in
- let exported = env.Passes.newFinalCompile_exported in
- let env_js_input = JsBackend.compile
- ~runtime_ast:false
- ~bsl:loaded_bsl.Qml2js.generated_ast
- ~val_:OpaMapToIdent.val_
- ~closure_map:env.Passes.newFinalCompile_closure_map
- ~is_distant
- ~renaming
- ~bsl_lang:BslLanguage.nodejs
- ~exported
- jsoptions
- env_bsl
- env.Passes.newFinalCompile_qml_milkshake.QmlBlender.env
- env.Passes.newFinalCompile_qml_milkshake.QmlBlender.code
- in
- let is_distant ident =
- match ident with
- | JsIdent.ExprIdent i ->
- (try
- ignore
- (QmlRenamingMap.new_from_original
- env.P.newFinalCompile_renaming_client
- i);
- true
- with Not_found -> false)
- | _ -> false
- in
- PH.make_env options {
- env_js_input;
- jsoptions;
- env_bsl;
- loaded_bsl;
- is_distant;
- }
- )
-
-let pass_ServerJavascriptOptimization =
- PassHandler.make_pass
- (fun e ->
- let env = e.PH.env in
- let exported = env.env_js_input.Qml2jsOptions.exported in
- let is_exported i = JsIdentSet.mem i exported || env.is_distant i in
- let js_code =
- Pass_ServerJavascriptOptimization.process_code
- is_exported
- env.env_js_input.Qml2jsOptions.js_code
- in
- let js_init_contents =
- List.map
- (fun (x, c) -> x,
- match c with
- | `string _ -> assert false
- | `ast proj -> `ast
- (List.map
- (fun (i, e) ->
- (i, Pass_ServerJavascriptOptimization.process_code_elt
- is_exported e))
- proj)
- ) env.env_js_input.Qml2jsOptions.js_init_contents
- in
- PH.make_env e.PH.options
- { env with env_js_input =
- { env.env_js_input with Qml2jsOptions. js_code; js_init_contents }
- }
- )
-
-let pass_ServerJavascriptGeneration =
+let pass_ServerQmlClosure =
PassHandler.make_pass
(fun e ->
- let env = e.PH.env in
- let jsoptions = env.jsoptions in
- let env_bsl = env.env_bsl in
- let loaded_bsl = env.loaded_bsl in
- let env_js_output =
- Qml2js.JsTreat.js_generation jsoptions env_bsl
- loaded_bsl env.env_js_input
- in
- let code = Qml2js.JsTreat.js_treat jsoptions env_js_output in
- PH.make_env e.PH.options code
- )
+ { e with PH.env = P.pass_QmlClosure2 ~typed:false ~side:`server ~options:e.PH.options e.PH.env })
let pass_CleanUp =
{ PH.
@@ -2456,9 +2149,6 @@ let () =
| "ServerQmlClosure"
| "QmlConstantSharing" -> Some (Obj.magic final_printers)
- | "QmlCompilation"
- | "OcamlGeneration"
- | "OcamlCompilation"
| "ByeBye" -> None
| _ -> None)
View
73 compiler/opa/s3Passes.mli
@@ -15,6 +15,7 @@
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
+
open Passes
(** Pass and pass utils for Opa S3. *)
@@ -41,43 +42,17 @@ type ('env, 'env2) opa_old_pass =
*)
type env_bothFinalCompile = (env_NewFinalCompile * env_NewFinalCompile)
-(**
- Environment returned by the QmlCompilation.
-*)
-type env_QmlCompilation = {
- qmlCompilation_options : Qml2ocamlOptions.argv_options ;
- qmlCompilation_env_ocaml_input : Qml2ocaml.env_ocaml_input ;
-}
-
-(**
- Environment returned after splitting ocaml code into smaller files
-*)
-type env_OcamlSplitCode = {
- ocamlSplitCode_options : Qml2ocamlOptions.argv_options ;
- ocamlSplitCode_env_ocaml_split : Qml2ocaml.env_ocaml_split ;
-}
-
-(**
- Environment returned by the OcamlGeneration.
-*)
-type env_OcamlGeneration = {
- ocamlGeneration_options : Qml2ocamlOptions.argv_options ;
- ocamlGeneration_env_ocaml_output : Qml2ocaml.env_ocaml_output ;
-}
-
-(**
- Environment returned by the OcamlCompilation.
-*)
-type env_OcamlCompilation = {
- ocamlCompilation_returned_code : int ;
-}
+module EnvUtils :
+sig
+ val jsutils_from_renamings : here:QmlRenamingMap.t -> other:QmlRenamingMap.t -> (Ident.t -> bool) * QmlRenamingMap.t
+end
(**{6 S3 Passes} All value bellow should be type of
[opa_pass].*)
-val pass_Welcome : (unit, opa_options, unit, unit) PassHandler.pass
+val pass_Welcome : string list -> (unit, opa_options, unit, unit) PassHandler.pass
-val pass_CheckOptions : (unit, env_ArgParse) opa_pass
+val pass_CheckOptions : (OpaEnv.opa_back_end -> OpaEnv.opa_back_end) -> (unit, env_ArgParse) opa_pass
(**
{6 Stdlib files}
@@ -124,6 +99,7 @@ val pass_DbEngineImportation :
opa_pass
val pass_BslLoading :
+ (OpaEnv.opa_back_end -> ((BslPluginInterface.plugin -> unit) option * BslLanguage.t)) ->
((((SurfaceAst.nonuid, SurfaceAst.parsing_directive)
SurfaceAst.code_elt) ObjectFiles.parsed_code) as 'parsed_code
,
@@ -239,6 +215,7 @@ val pass_FunActionLifting :
(unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
val pass_TypesDefinitions :
+ (OpaEnv.opa_back_end -> (string -> unit)) ->
(unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
val pass_DbSchemaGeneration :
@@ -308,6 +285,7 @@ val pass_BypassHoisting :
(unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
val pass_RegisterFields :
+ (OpaEnv.opa_back_end -> (string -> unit)) ->
(unit Passes.env_Gen, unit Passes.env_Gen) opa_pass
val pass_QmlUndot :
@@ -403,39 +381,9 @@ val pass_ServerCpsRewriter :
val pass_QmlConstantSharing :
(env_NewFinalCompile, env_NewFinalCompile) opa_pass
-(* ***********************************************)
-(* FINAL QMLFLAT COMPILATION *********************)
-
val pass_ServerQmlClosure :
(env_NewFinalCompile, env_NewFinalCompile) opa_pass
-val pass_QmlCompilation :
- (env_NewFinalCompile, env_QmlCompilation) opa_pass
-
-val pass_OcamlSplitCode :
- (env_QmlCompilation, env_OcamlSplitCode) opa_pass
-
-val pass_OcamlGeneration :
- (env_OcamlSplitCode, env_OcamlGeneration) opa_pass
-
-val pass_OcamlCompilation :
- (env_OcamlGeneration, int) opa_pass
-
-(* ***********************************************)
-(* FINAL QMLJS COMPILATION ***********************)
-
-(** Environment needed by the final JavasScript compilation. *)
-type env_JsCompilation
-
-val pass_ServerJavascriptCompilation :
- (env_NewFinalCompile, env_JsCompilation) opa_pass
-
-val pass_ServerJavascriptOptimization :
- (env_JsCompilation, env_JsCompilation) opa_pass
-
-val pass_ServerJavascriptGeneration :
- (env_JsCompilation, int) opa_pass
-
(* ***********************************************)
(* END OF COMPILATION *****************************)
@@ -443,7 +391,6 @@ val pass_CleanUp : ('opt, 'opt, int, int) PassHandler.pass
val pass_ByeBye : (_, unit, int, unit) PassHandler.pass
-
(* ***********************************************)
(* UNUSED PASSES *********************************)
val pass_QmlLiftDeepRecords :
View
8 compiler/opa/syntaxHelper.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of Opa.
@@ -16,7 +16,7 @@
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
-(** The main program for the Opa compiler. S3 version. *)
+(** The main program for Opa translate tool. *)
(* Opening the generic pass system. *)
module PH = PassHandler
@@ -50,9 +50,9 @@ let _ = WarningClass.load_set S3Warnings.warning_set
let _ =
PH.init
- |+> ("Welcome", S3.pass_Welcome)
+ |+> ("Welcome", S3.pass_Welcome ["qmljs"])
- |+> ("CheckOptions", S3.pass_CheckOptions)
+ |+> ("CheckOptions", S3.pass_CheckOptions Base.identity)
|+> ("AddStdlibFiles", S3.pass_AddStdlibFiles)
View
20 compiler/opalang/classic_syntax/parser_utils.ml
@@ -122,7 +122,7 @@ let hint_color = Ansi.print `magenta
let error1 s annot =
raise (Specific_parse_error (annot.QmlLoc.pos,s))
-let error_rbrace_in_html =
+let error_rbrace_in_html =
error1 (sprintf ("%s is treated as a special character in html,\n if you want to use it you have to escape it: %s")
(hint_color "}") (hint_color "\\}"))
let error_comment = error1 "you start an unterminated comment (the `/*' is not matched by a `*/')."
@@ -1131,7 +1131,7 @@ let xhtml_mode () = Stack.top xml_stack = Xhtml
let xml_typename () = if xhtml_mode () then Opacapi.Types.xhtml else Opacapi.Types.xml
exception No_tag
-let tag_stack : (string * QmlLoc.annot) Stack.t = (Stack.create ())
+let tag_stack : (string * QmlLoc.annot) Stack.t = (Stack.create ())
let push_tag s = Stack.push s tag_stack
let get_tag_with_annot () = try Stack.top tag_stack with | Stack.Empty -> raise No_tag
let get_tag () = undecorate (get_tag_with_annot ())
@@ -1152,7 +1152,7 @@ let rec find_next_tag context pos tag_open tag_close=
then (s1, false)
else find_next_tag context (s1+1) tag_open tag_close
)
- with Not_found -> (String.length context, true)
+ with Not_found -> (String.length context, true)
let count_close_tags_in_string content tag =
@@ -1160,15 +1160,15 @@ let count_close_tags_in_string content tag =
let tag_name = "<" ^ undecorate tag ^ ">" in
let end_tag = "</" ^ undecorate tag ^ ">" in
let rec aux current_pos (next_tag_pos, starting_tag) =
- if next_tag_pos < String.length content
+ if next_tag_pos < String.length content
then (
if starting_tag then decr num else incr num ;
- let finish_tag =
- current_pos +
- (if starting_tag
- then String.length tag_name
+ let finish_tag =
+ current_pos +
+ (if starting_tag
+ then String.length tag_name
else String.length end_tag) in
- let (new_tag_pos, new_starting_tag) =
+ let (new_tag_pos, new_starting_tag) =
find_next_tag content current_pos tag_name end_tag in
aux finish_tag (new_tag_pos, new_starting_tag)
)
@@ -1598,7 +1598,7 @@ and rewrite_record_extend (e:(_,_) expr) (ts:tree list) =
else
let i = fresh_name () in
(Ident i, nlabel e), (fun body -> (LetIn (false, [i, e], body), nlabel e)) in
- wrapper (
+ wrapper (
(Directive(`extendwith, [
wrapper (ExtendRecord (
List.rev_map (fun (((s,_),_) as t) -> (s, rewrite_record_extend_aux path t)) ts,
View
74 compiler/opalib/opaEnv.ml
@@ -102,22 +102,6 @@ let cwd = Sys.getcwd ()
let available_js_back_end_list = Qml2jsOptions.backend_names ()
let available_js_back_end_of_string = Qml2jsOptions.find_backend
-type available_back_end = [ `qmlflat | `qmljs ]
-let available_back_end_list = [ "qmlflat" ; "qmljs" ; "native" ; "node" ; "js" ; "nodejs"; "node.js" ]
-let available_back_end_of_string : string -> available_back_end option = function
- | "native"
- | "qmlflat" -> Some `qmlflat
- | "node"
- | "js"
- | "nodejs"
- | "node.js"
- | "qmljs" -> Some `qmljs
- | _ -> None
-let string_of_available_back_end : available_back_end -> string = function
- | `qmlflat -> "qmlflat"
- | `qmljs -> "qmljs"
-
-
let available_js_bypass_syntax_list = ["classic"; "jsdoc"; "new"]
let js_bypass_syntax_of_string = function
| "classic" -> Some `classic
@@ -128,6 +112,10 @@ let js_bypass_syntax : [`classic | `jsdoc] ref = ref `classic
let set_js_bypass_syntax s =
js_bypass_syntax := Option.get (js_bypass_syntax_of_string s)
+type opa_back_end = Backend of string
+
+let string_of_available_back_end = function | Backend s -> s
+
type opa_options = {
ocamlc : string ;
@@ -140,7 +128,7 @@ type opa_options = {
mllopt : string list ;
makefile_rule : Qml2ocamlOptions.makefile_rule ;
- back_end : available_back_end ;
+ back_end : opa_back_end ;
js_back_end : (module Qml2jsOptions.JsBackend) ;
hacker_mode : bool ;
@@ -215,7 +203,7 @@ let i18n_template option = option.i18n.I18n.template_opa || option.i18n.I18n.tem
module Options :
sig
- val parse_options : unit -> unit
+ val parse_options : string list -> unit
val get_options : unit -> opa_options
val echo_help : unit -> unit
@@ -308,20 +296,18 @@ struct
let modular_plugins = ref false
- let back_end_wanted = ref ( `qmljs : available_back_end )
+ let default_back_end = "qmljs"
+ let back_end_wanted = ref (Backend default_back_end : opa_back_end)
let back_end s =
- let back_end =
- match available_back_end_of_string s with
- | None -> assert false (* use symbol in Arg.parse *)
- | Some back_end -> back_end in
+ let back_end = Backend s in
back_end_wanted := back_end;
match back_end with
- | `qmlflat ->
- js_serialize := `adhoc;
- QmlAstUtils.Const.set_limits `ml
- | `qmljs ->
+ | Backend "qmljs" ->
js_serialize := `ast;
QmlAstUtils.Const.set_limits `js
+ | _ ->
+ js_serialize := `adhoc;
+ QmlAstUtils.Const.set_limits `ml
let js_back_end_wanted_name = "qmljsimp"
let js_back_end_wanted = ref (available_js_back_end_of_string js_back_end_wanted_name)
let js_back_end s =
@@ -481,7 +467,7 @@ struct
(the function is updated just after the definition of the options list) *)
(* ===== *)
- let speclist =
+ let speclist available_back_end_list =
let standard = (* Please preverse the alphabetical order for lisibility *)
OManager.Arg.options @
WarningClass.Arg.options @
@@ -502,10 +488,14 @@ struct
Arg.Set generate_interface,
" Generate interfaces (json and text) and exit"
;
+ ] @ (
+ if List.length available_back_end_list > 1 then [
- ("--back-end", Arg.Symbol (available_back_end_list, back_end),
- (Printf.sprintf "Select a backend between (default is %s)"
- (string_of_available_back_end !back_end_wanted)));
+ ("--back-end", Arg.Symbol (available_back_end_list, back_end),
+ (Printf.sprintf "Select the backend (default is %s)"
+ (default_back_end)));
+ ] else []
+ ) @ [
(* b *)
"--build-dir",
@@ -721,7 +711,7 @@ struct
)
)
- let parse () =
+ let parse available_back_end_list =
let anon_fun arg =
let ext = File.extension arg in
match ext with
@@ -789,24 +779,24 @@ struct
let opack_options = Sys.argv.(0) :: (List.rev opack_options) in
let opack_options = Array.of_list opack_options in
try
- Arg.parse_argv ~current:(ref 0) opack_options speclist anon_fun ("")
+ Arg.parse_argv ~current:(ref 0) opack_options (speclist available_back_end_list) anon_fun ("")
with
| Arg.Bad message ->
OManager.error "error while reading opack file @{<bright>%S@} :@\n%s@" file message
| Arg.Help _ ->
- help_menu speclist () ;
+ help_menu (speclist available_back_end_list) () ;
OManager.error "error, the opack file @{<bright>%S@} contains the option --help" file
in
(** updating options depending on options *)
let _ =
opack_file_function := opack_file_rule ;
- full_help := help_menu speclist
+ full_help := help_menu (speclist available_back_end_list)
in
(** Default opack file *)
let default_opack = File.concat (Lazy.force File.mlstate_dir) "default.opack" in
let _ = if File.is_regular default_opack then opack_file_rule default_opack in
(** Main Command line *)
- Arg.parse speclist anon_fun "";
+ Arg.parse (speclist available_back_end_list) anon_fun "";
(** Print_help **)
if !print_help then begin
do_print_help ();
@@ -822,8 +812,8 @@ struct
filenames := MutableList.to_list mutable_filenames;
target := (
let ext = match !back_end_wanted with
- | `qmljs -> ".js"
- | `qmlflat -> ".exe"
+ | Backend "qmljs" -> ".js"
+ | _ -> ".exe"
in
Option.default (!last_target_from_file ^ ext) !target_opt);
target_only_qml := Option.default (!last_target_from_file ^ ".qml") !target_opt;
@@ -833,8 +823,8 @@ struct
end
(* Parse and get options, work with a side effect on module ArgParser *)
- let parse_options () =
- ArgParser.parse ();
+ let parse_options available_back_end_list =
+ ArgParser.parse available_back_end_list;
begin
OpaWalker.Options.disp := match !ArgParser.opa_walker with
| Some true -> OpaWalker.Options.True
@@ -961,7 +951,7 @@ struct
let module JsCC = (val options.js_back_end : Qml2jsOptions.JsBackend) in
Pprocess.add_env "OPA_JS_COMPILER" JsCC.name env
in let env =
- if options.back_end = `qmljs then
+ if options.back_end = Backend "qmljs" then
let env = Pprocess.add_env "OPA_BACKEND_QMLJS" "1" env in
let env = Pprocess.add_env "OPA_CHANNEL" "1" env in
Pprocess.add_env "OPA_FULL_DISPATCHER" "1" env
@@ -976,7 +966,7 @@ struct
~centerheader:"Opa Manual"
~synopsis:ArgParser.synopsis
~description:"The Opa compiler allows you to compile Opa projects into executable files. Please refer to the online manual on http://doc.opalang.org for a detailed description of the language and its tools.\n"
- ~options:ArgParser.speclist
+ ~options:(ArgParser.speclist ["qmljs"])
~other:[("VERSION", ArgParser.str_version)]
file
View
2  compiler/passes/pass_CheckOptionsConsistency.ml
@@ -16,7 +16,7 @@
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
type relevant_options =
- { back_end : OpaEnv.available_back_end
+ { back_end : OpaEnv.opa_back_end
; js_back_end : string
; closure : bool
; cps : bool
View
2  compiler/passes/pass_CheckOptionsConsistency.mli
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of Opa.
Please sign in to comment.
Something went wrong with that request. Please try again.