Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
Frederic Ye committed Oct 9, 2012
1 parent acf1c6a commit 1851a1b
Show file tree
Hide file tree
Showing 18 changed files with 1,175 additions and 716 deletions.
4 changes: 2 additions & 2 deletions compiler/opa/_tags
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -57,8 +57,8 @@
<opa_parse.ml>: use_opalib, use_opalang, use_opapasses <opa_parse.ml>: use_opalib, use_opalang, use_opapasses


# s3 main # 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 <{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,gen_opa_manpage}.ml>: use_opalib, use_opalang, use_opapasses, use_libqmlcompil, use_qml2ocaml, use_passlib <{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 <syntaxHelper.ml>: use_opalib, use_opalang, use_opapasses, use_libqmlcompil, use_qml2ocaml, use_passlib


# linking # linking
Expand Down
353 changes: 353 additions & 0 deletions compiler/opa/compiler.ml
View file
Original file line number Original file line Diff line number Diff line change
@@ -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
Loading

0 comments on commit 1851a1b

Please sign in to comment.