From b798ac29c37299b2f761243ae92ab8f7c4c4d7f1 Mon Sep 17 00:00:00 2001 From: Paweł Dybiec Date: Tue, 30 Oct 2018 15:32:56 +0100 Subject: Initial commit --- source/xi/plugin_manager.ml | 245 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 245 insertions(+) create mode 100644 source/xi/plugin_manager.ml (limited to 'source/xi/plugin_manager.ml') diff --git a/source/xi/plugin_manager.ml b/source/xi/plugin_manager.ml new file mode 100644 index 0000000..3c6cdf0 --- /dev/null +++ b/source/xi/plugin_manager.ml @@ -0,0 +1,245 @@ +open Xi_lib +open Plugin_register + +type plugin = string * (module Plugin.PLUGIN) + +module Getters = struct + + let make_live_variables_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_live_variables_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_dominators_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_dominators_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_reachability_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_reachability_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_scheduler (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_scheduler with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_natural_loops_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_natural_loops_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_spill_costs_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_spill_costs_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let lexer_and_parser (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.lexer_and_parser with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_typechecker (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_typechecker with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_translator (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_translator with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_jump_threading (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_jump_threading with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_constant_folding (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_constant_folding with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_hilower (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_hilower with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_callconv (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_callconv with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_mipslower (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_mipslower with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_register_allocator (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_register_allocator with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_dead_code_elimination (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_dead_code_elimination with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_codegen (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_codegen with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_constant_folding_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_constant_folding_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_interference_graph_analysis (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_interference_graph_analysis with + | Some x -> Some (name, Plugin.version, x) + | None -> None + + let make_spilling (name, plugin) = + let module Plugin = (val plugin : Plugin.PLUGIN) in + match Plugin.make_spilling with + | Some x -> Some (name, Plugin.version, x) + | None -> None +end + +module Resolver = struct + + let rec find_module name getter = function + | [] -> + failwith @@ Format.sprintf "Cannot find %s" name + | x::xs -> + match getter x with + | Some (modname, version, impl) -> + Format.eprintf "module %s=%s:%s\n%!" name modname version; + impl + | None -> + find_module name getter xs + + let make_live_variables_analysis = find_module "MakeLiveVariablesAnalysis" Getters.make_live_variables_analysis + + let make_dominators_analysis = find_module "MakeDominanceAnalysis" Getters.make_dominators_analysis + + let make_reachability_analysis = find_module "MakeReachabilityAnalysis" Getters.make_reachability_analysis + + let make_scheduler = find_module "MakeScheduler" Getters.make_scheduler + + let make_natural_loops_analysis = find_module "MakeNaturalLoopsAnalysis" Getters.make_natural_loops_analysis + + let make_spill_costs_analysis = find_module "MakeSpillCostsAnalysis" Getters.make_spill_costs_analysis + + let lexer_and_parser = find_module "LexerAndParser" Getters.lexer_and_parser + + let make_typechecker = find_module "MakeTypechecker" Getters.make_typechecker + + let make_translator = find_module "MakeTranslator" Getters.make_translator + + let make_jump_threading = find_module "MakeJumpThreading" Getters.make_jump_threading + + let make_constant_folding = find_module "MakeConstantFolding" Getters.make_constant_folding + + let make_hilower = find_module "MakeHiLower" Getters.make_hilower + + let make_callconv = find_module "MakeCallConv" Getters.make_callconv + + let make_mipslower = find_module "MakeMipsLower" Getters.make_mipslower + + let make_register_allocator = find_module "MakeRegisterAllocator" Getters.make_register_allocator + + let make_dead_code_elimination = find_module "MakeDeadCodeElimination" Getters.make_dead_code_elimination + + let make_codegen = find_module "MakeCodegen" Getters.make_codegen + + let make_constant_folding_analysis = find_module "MakeConstantFoldingAnalysis" Getters.make_constant_folding_analysis + + let make_interference_graph_analysis = find_module "MakeInterferenceGraphAnalysis" Getters.make_interference_graph_analysis + + let make_spilling = find_module "MakeSpilling" Getters.make_spilling + +end + +let resolve_compiler_toolbox regdescr = + let module MakeLiveVariablesAnalysis = (val Resolver.make_live_variables_analysis !register) in + let module MakeDominatorsAnalysis = (val Resolver.make_dominators_analysis !register) in + let module MakeNaturalLoopsAnalysis = (val Resolver.make_natural_loops_analysis !register) in + let module MakeSpillCostsAnalysis = (val Resolver.make_spill_costs_analysis !register) in + let module MakeScheduler = (val Resolver.make_scheduler !register) in + let module MakeConstantFoldingAnalysis = (val Resolver.make_constant_folding_analysis !register) in + let module MakeInterferenceGraphAnalysis = (val Resolver.make_interference_graph_analysis !register) in + let module MakeSpilling = (val Resolver.make_spilling !register) in + let module MakeReachabilityAnalysis = (val Resolver.make_reachability_analysis !register) in + let module M = struct + module LiveVariablesAnalysis = MakeLiveVariablesAnalysis() + module DominatorsAnalysis = MakeDominatorsAnalysis() + module Scheduler = MakeScheduler() + module NaturalLoopsAnalysis = MakeNaturalLoopsAnalysis() + module SpillCostsAnalysis = MakeSpillCostsAnalysis() + module RegistersDescription = (val regdescr : Ir_arch.REGISTERS_DESCRIPTION) + module ConstantFoldingAnalysis = MakeConstantFoldingAnalysis() + module InterferenceGraphAnalysis = MakeInterferenceGraphAnalysis() + module Spilling = MakeSpilling() + module ReachabilityAnalysis = MakeReachabilityAnalysis() + end in + (module M : Iface.COMPILER_TOOLBOX) + +let resolve_compiler_steps regdescr = + let module CompilerToolbox = (val resolve_compiler_toolbox regdescr : Iface.COMPILER_TOOLBOX) in + let module LexerAndParser = (val Resolver.lexer_and_parser !register) in + let module MakeTypechecker = (val Resolver.make_typechecker !register) in + let module MakeTranslator = (val Resolver.make_translator !register) in + let module MakeJumpThreading = (val Resolver.make_jump_threading !register) in + let module MakeConstantFolding = (val Resolver.make_constant_folding !register) in + let module MakeHiLower = (val Resolver.make_hilower !register) in + let module MakeCallConv = (val Resolver.make_callconv !register) in + let module MakeMipsLower = (val Resolver.make_mipslower !register) in + let module MakeRegisterAllocator = (val Resolver.make_register_allocator !register) in + let module MakeDeadCodeElimination = (val Resolver.make_dead_code_elimination !register) in + let module MakeCodegen = (val Resolver.make_codegen !register) in + + let module Steps = struct + module Toolbox = CompilerToolbox + module LexerAndParser = LexerAndParser + module Typechecker = MakeTypechecker() + module Translator = MakeTranslator() + module JumpThreading = MakeJumpThreading() + module HiLower = MakeHiLower(CompilerToolbox) + module CallConv = MakeCallConv(CompilerToolbox) + module MipsLower = MakeMipsLower(CompilerToolbox) + module RegisterAllocator = MakeRegisterAllocator(CompilerToolbox) + module ConstantFolding = MakeConstantFolding(CompilerToolbox) + module DeadCodeElimination = MakeDeadCodeElimination(CompilerToolbox) + module Codegen = MakeCodegen(CompilerToolbox) + end in + + (module Steps : Iface.COMPILER_STEPS) + +let load_plugin path = + try + Plugin_register.current_file := Filename.basename path; + Dynlink.loadfile path; + Plugin_register.current_file := ""; + with Dynlink.Error e -> + failwith @@ Format.sprintf "Cannot load plugin '%s': %s" path (Dynlink.error_message e) \ No newline at end of file -- cgit 1.4.1