From d9a655dad8e013e41c74dca98fb86c4ed6f29879 Mon Sep 17 00:00:00 2001 From: Adam Megacz Date: Sat, 18 Jun 2011 17:34:50 -0700 Subject: [PATCH] put coqPassCoreToCore on the CoreM monad, greatly simplify Desugar.lhs --- compiler/deSugar/Desugar.lhs | 184 +++++++----------------------------------- compiler/hetmet | 2 +- 2 files changed, 28 insertions(+), 158 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 8ac2819..16e690f 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -16,6 +16,7 @@ import TcRnTypes import MkIface import IfaceEnv import Id +import IOEnv import Pair import Name import FastString @@ -34,7 +35,8 @@ import RdrName import NameSet import NameEnv import Rules -import CoreMonad ( endPass, CoreToDo(..) ) +import CoreMonad ( endPass, CoreToDo(..), CoreM, runCoreM, lookupOrigCoreM ) +import TyCon import ErrUtils import Outputable import SrcLoc @@ -100,7 +102,7 @@ deSugar hsc_env <- case target of HscNothing -> return (emptyMessages, - Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined)) + Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) _ -> do (binds_cvr,ds_hpc_info, modBreaks) <- if (opt_Hpc @@ -117,93 +119,6 @@ deSugar hsc_env ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects - ; junk <- if dopt Opt_F_coqpass dflags - then do { hetmet_brak_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_brak")) - ; hetmet_brak <- dsLookupGlobalId hetmet_brak_name - ; hetmet_esc_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_esc")) - ; hetmet_esc <- dsLookupGlobalId hetmet_esc_name - ; hetmet_flatten_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_flatten")) - ; hetmet_flatten <- dsLookupGlobalId hetmet_flatten_name - ; hetmet_unflatten_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "pga_unflatten")) - ; hetmet_unflatten <- dsLookupGlobalId hetmet_unflatten_name - ; hetmet_flattened_id_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "pga_flattened_id")) - ; hetmet_flattened_id <- dsLookupGlobalId hetmet_flattened_id_name - ; hetmet_PGArrow_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS tcName (fsLit "PGArrow")) - ; hetmet_PGArrow <- dsLookupTyCon hetmet_PGArrow_name - ; hetmet_PGArrow_unit_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowUnit")) - ; hetmet_PGArrow_unit <- dsLookupTyCon hetmet_PGArrow_unit_name - ; hetmet_PGArrow_tensor_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowTensor")) - ; hetmet_PGArrow_tensor <- dsLookupTyCon hetmet_PGArrow_tensor_name - ; hetmet_PGArrow_exponent_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowExponent")) - ; hetmet_PGArrow_exponent <- dsLookupTyCon hetmet_PGArrow_exponent_name - ; hetmet_pga_id_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_id")) - ; hetmet_pga_id <- dsLookupGlobalId hetmet_pga_id_name - ; hetmet_pga_comp_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_comp")) - ; hetmet_pga_comp <- dsLookupGlobalId hetmet_pga_comp_name - ; hetmet_pga_first_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_first")) - ; hetmet_pga_first <- dsLookupGlobalId hetmet_pga_first_name - ; hetmet_pga_second_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_second")) - ; hetmet_pga_second <- dsLookupGlobalId hetmet_pga_second_name - ; hetmet_pga_cancell_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_cancell")) - ; hetmet_pga_cancell <- dsLookupGlobalId hetmet_pga_cancell_name - ; hetmet_pga_cancelr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_cancelr")) - ; hetmet_pga_cancelr <- dsLookupGlobalId hetmet_pga_cancelr_name - ; hetmet_pga_uncancell_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_uncancell")) - ; hetmet_pga_uncancell <- dsLookupGlobalId hetmet_pga_uncancell_name - ; hetmet_pga_uncancelr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_uncancelr")) - ; hetmet_pga_uncancelr <- dsLookupGlobalId hetmet_pga_uncancelr_name - ; hetmet_pga_assoc_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_assoc")) - ; hetmet_pga_assoc <- dsLookupGlobalId hetmet_pga_assoc_name - ; hetmet_pga_unassoc_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_unassoc")) - ; hetmet_pga_unassoc <- dsLookupGlobalId hetmet_pga_unassoc_name - ; hetmet_pga_copy_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_copy")) - ; hetmet_pga_copy <- dsLookupGlobalId hetmet_pga_copy_name - ; hetmet_pga_drop_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_drop")) - ; hetmet_pga_drop <- dsLookupGlobalId hetmet_pga_drop_name - ; hetmet_pga_swap_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_swap")) - ; hetmet_pga_swap <- dsLookupGlobalId hetmet_pga_swap_name - ; hetmet_pga_applyl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_applyl")) - ; hetmet_pga_applyl <- dsLookupGlobalId hetmet_pga_applyl_name - ; hetmet_pga_applyr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_applyr")) - ; hetmet_pga_applyr <- dsLookupGlobalId hetmet_pga_applyr_name - ; hetmet_pga_curryl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_curryl")) - ; hetmet_pga_curryl <- dsLookupGlobalId hetmet_pga_curryl_name - ; hetmet_pga_curryr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_curryr")) - ; hetmet_pga_curryr <- dsLookupGlobalId hetmet_pga_curryr_name - ; hetmet_pga_loopl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_loopl")) - ; hetmet_pga_loopl <- dsLookupGlobalId hetmet_pga_loopl_name - ; hetmet_pga_loopr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_loopr")) - ; hetmet_pga_loopr <- dsLookupGlobalId hetmet_pga_loopr_name - ; return ( hetmet_brak - , hetmet_esc - , hetmet_flatten - , hetmet_unflatten - , hetmet_flattened_id - , hetmet_PGArrow - , hetmet_PGArrow_unit - , hetmet_PGArrow_tensor - , hetmet_PGArrow_exponent - , hetmet_pga_id - , hetmet_pga_comp - , hetmet_pga_first - , hetmet_pga_second - , hetmet_pga_cancell - , hetmet_pga_cancelr - , hetmet_pga_uncancell - , hetmet_pga_uncancelr - , hetmet_pga_assoc - , hetmet_pga_unassoc - , hetmet_pga_copy - , hetmet_pga_drop - , hetmet_pga_swap - , hetmet_pga_applyl - , hetmet_pga_applyr - , hetmet_pga_curryl - , hetmet_pga_curryr - , hetmet_pga_loopl - , hetmet_pga_loopr ) - } - else return undefined ; let hpc_init | opt_Hpc = hpcInitCode mod ds_hpc_info | otherwise = empty @@ -211,12 +126,12 @@ deSugar hsc_env , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules, ds_vects , ds_fords `appendStubC` hpc_init - , ds_hpc_info, modBreaks, junk) + , ds_hpc_info, modBreaks) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks, junk) -> do + Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@ -240,74 +155,29 @@ deSugar hsc_env else return (final_pgm, rules_for_imps, vects0) ; ds_binds1 <- if dopt Opt_F_coqpass dflags - then do { us <- mkSplitUniqSupply '~' + then do { us1 <- mkSplitUniqSupply '*' -- hack + ; us2 <- mkSplitUniqSupply '~' -- hack ; let do_flatten = dopt Opt_F_flatten dflags ; let do_skolemize = dopt Opt_F_skolemize dflags - ; (case junk of { - ( hetmet_brak , - hetmet_esc , - hetmet_flatten , - hetmet_unflatten , - hetmet_flattened_id , - hetmet_PGArrow , - hetmet_PGArrow_unit , - hetmet_PGArrow_tensor , - hetmet_PGArrow_exponent , - hetmet_pga_id , - hetmet_pga_comp , - hetmet_pga_first , - hetmet_pga_second , - hetmet_pga_cancell , - hetmet_pga_cancelr , - hetmet_pga_uncancell , - hetmet_pga_uncancelr , - hetmet_pga_assoc , - hetmet_pga_unassoc , - hetmet_pga_copy , - hetmet_pga_drop , - hetmet_pga_swap , - hetmet_pga_applyl , - hetmet_pga_applyr , - hetmet_pga_curryl , - hetmet_pga_curryr , - hetmet_pga_loopl , - hetmet_pga_loopr ) -> - return (coqPassCoreToCore - do_flatten - do_skolemize - hetmet_brak - hetmet_esc - hetmet_flatten - hetmet_unflatten - hetmet_flattened_id - us - final_pgm1 - hetmet_PGArrow - hetmet_PGArrow_unit - hetmet_PGArrow_tensor - hetmet_PGArrow_exponent - hetmet_pga_id - hetmet_pga_comp - hetmet_pga_first - hetmet_pga_second - hetmet_pga_cancell - hetmet_pga_cancelr - hetmet_pga_uncancell - hetmet_pga_uncancelr - hetmet_pga_assoc - hetmet_pga_unassoc - hetmet_pga_copy - hetmet_pga_drop - hetmet_pga_swap - hetmet_pga_applyl - hetmet_pga_applyr - hetmet_pga_curryl - hetmet_pga_curryr - hetmet_pga_loopl - hetmet_pga_loopr - ) - } - ) + ; let mon = runCoreM hsc_env (mkRuleBase rules_for_imps1) us1 mod + $ coqPassCoreToCore do_flatten do_skolemize dsLookupVar dsLookupTyc us2 final_pgm1 + where + dsLookupVar :: String -> String -> CoreM Var + dsLookupVar modname varname + = do { name <- lookupOrigCoreM + (mkBaseModule (fsLit modname)) + (mkOccNameFS varName (fsLit varname)) + ; lookupId name + } + dsLookupTyc :: String -> String -> CoreM TyCon + dsLookupTyc modname tycname + = do { name <- lookupOrigCoreM + (mkBaseModule (fsLit modname)) + (mkOccNameFS tcName (fsLit tycname)) + ; lookupTyCon name + } + ; (ret,_) <- mon + ; return ret } else return final_pgm diff --git a/compiler/hetmet b/compiler/hetmet index 7c9df3b..68f5bca 160000 --- a/compiler/hetmet +++ b/compiler/hetmet @@ -1 +1 @@ -Subproject commit 7c9df3b89842f11d0bcb00ab24012160174e5f7a +Subproject commit 68f5bca870525f0740a4c5cb1fdbc7c7ce270306 -- 1.7.10.4