thread wired-in names of GHC.HetMet.Private.* through to Coq code

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 603c858..4276414 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -92,7 +92,26 @@ deSugar hsc_env
               <- case target of
                   HscNothing ->
                        return (emptyMessages,
-                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined))
+                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                                    , undefined
+                               ))
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
                         <- if (opt_Hpc
@@ -110,6 +129,24 @@ deSugar hsc_env
                           ; ds_vects <- mapM dsVect vects
                           ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
                           ; hetmet_esc  <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name  else return undefined
+                          ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
+                          ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
+                          ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
+                          ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
+                          ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
+                          ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
+                          ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
+                          ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
+                          ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
+                          ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
+                          ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
+                          ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
+                          ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
+                          ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
+                          ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
+                          ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
+                          ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
+                          ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
                           ; let hpc_init
                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
@@ -117,11 +154,48 @@ 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, hetmet_brak, hetmet_esc) }
+                                   , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
+                                   , hetmet_PGArrow
+                                   , 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
+                                   ) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) -> do
+           Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
+                                   , hetmet_PGArrow
+                                   , 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) -> do
 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
@@ -146,14 +220,36 @@ deSugar hsc_env
                         -- The simpleOptPgm gets rid of type 
                         -- bindings plus any stupid dead code
 
-        ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds
-
         ; ds_binds' <- if dopt Opt_F_coqpass dflags
                        then do { us <- mkSplitUniqSupply '~'
-                               ; return $ coqPassCoreToCore hetmet_brak hetmet_esc us ds_binds
+                               ; return (coqPassCoreToCore
+                                             hetmet_brak
+                                             hetmet_esc
+                                             us
+                                             ds_binds
+                                             hetmet_PGArrow
+                                             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)
                                }
                        else return ds_binds
 
+        ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
+
         ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
 
        ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps

diff --git a/compiler/hetmet b/compiler/hetmet
index b18f84a..cb42497 160000 (submodule)
--- a/compiler/hetmet
+++ b/compiler/hetmet
@@ -1 +1 @@
-Subproject commit b18f84ae40af08b3df0214593f4e4eb0665cdf7d
+Subproject commit cb424978e057bc2b4868517302738d52246fba04

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index f4d4329..69eb8e9 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -216,6 +216,24 @@ basicKnownKeyNames
         hetmet_brak_name, hetmet_esc_name, hetmet_csp_name,
         hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name,
                                          hetmet_guest_char_literal_name,
+        hetmet_PGArrow_name,
+        hetmet_pga_id_name,
+        hetmet_pga_comp_name,
+        hetmet_pga_first_name,
+        hetmet_pga_second_name,
+        hetmet_pga_cancell_name,
+        hetmet_pga_cancelr_name,
+        hetmet_pga_uncancell_name,
+        hetmet_pga_uncancelr_name,
+        hetmet_pga_assoc_name,
+        hetmet_pga_unassoc_name,
+        hetmet_pga_copy_name,
+        hetmet_pga_drop_name,
+        hetmet_pga_swap_name,
+        hetmet_pga_applyl_name,
+        hetmet_pga_applyr_name,
+        hetmet_pga_curryl_name,
+        hetmet_pga_curryr_name,
 
         -- Annotation type checking
         toAnnotationWrapperName
@@ -264,6 +282,7 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
     gHC_CLASSES, gHC_BASE, gHC_ENUM,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
     gHC_HETMET_CODETYPES,
+    gHC_HETMET_PRIVATE,
     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
@@ -287,6 +306,7 @@ gHC_NUM             = mkBaseModule (fsLit "GHC.Num")
 gHC_INTEGER    = mkIntegerModule (fsLit "GHC.Integer")
 gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
 gHC_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes")
+gHC_HETMET_PRIVATE   = mkBaseModule (fsLit "GHC.HetMet.Private")
 gHC_LIST        = mkBaseModule (fsLit "GHC.List")
 gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")
 dATA_TUPLE      = mkBaseModule (fsLit "Data.Tuple")
@@ -792,6 +812,43 @@ hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIn
 hetmet_guest_string_literal_name  = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral")  hetmet_guest_string_literal_key
 hetmet_guest_char_literal_name    = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral")    hetmet_guest_char_literal_key
 
+hetmet_PGArrow_name :: Name
+hetmet_PGArrow_name = tcQual gHC_HETMET_PRIVATE (fsLit "PGArrow") hetmet_PGArrow_key
+hetmet_pga_id_name :: Name
+hetmet_pga_id_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_id") hetmet_pga_id_key
+hetmet_pga_comp_name :: Name
+hetmet_pga_comp_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_comp") hetmet_pga_comp_key
+hetmet_pga_first_name :: Name
+hetmet_pga_first_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_first") hetmet_pga_first_key
+hetmet_pga_second_name :: Name
+hetmet_pga_second_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_second") hetmet_pga_second_key
+hetmet_pga_cancell_name :: Name
+hetmet_pga_cancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancell") hetmet_pga_cancell_key
+hetmet_pga_cancelr_name :: Name
+hetmet_pga_cancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancelr") hetmet_pga_cancelr_key
+hetmet_pga_uncancell_name :: Name
+hetmet_pga_uncancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancell") hetmet_pga_uncancell_key
+hetmet_pga_uncancelr_name :: Name
+hetmet_pga_uncancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancelr") hetmet_pga_uncancelr_key
+hetmet_pga_assoc_name :: Name
+hetmet_pga_assoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_assoc") hetmet_pga_assoc_key
+hetmet_pga_unassoc_name :: Name
+hetmet_pga_unassoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_unassoc") hetmet_pga_unassoc_key
+hetmet_pga_copy_name :: Name
+hetmet_pga_copy_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_copy") hetmet_pga_copy_key
+hetmet_pga_drop_name :: Name
+hetmet_pga_drop_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_drop") hetmet_pga_drop_key
+hetmet_pga_swap_name :: Name
+hetmet_pga_swap_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_swap") hetmet_pga_swap_key
+hetmet_pga_applyl_name :: Name
+hetmet_pga_applyl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyl") hetmet_pga_applyl_key
+hetmet_pga_applyr_name :: Name
+hetmet_pga_applyr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyr") hetmet_pga_applyr_key
+hetmet_pga_curryl_name :: Name
+hetmet_pga_curryl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryl") hetmet_pga_curryl_key
+hetmet_pga_curryr_name :: Name
+hetmet_pga_curryr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryr") hetmet_pga_curryr_key
+
 -- IO things
 ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
     failIOName :: Name
@@ -1359,6 +1416,44 @@ hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_
 hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134
 hetmet_guest_string_literal_key  = mkPreludeMiscIdUnique 135
 hetmet_guest_char_literal_key    = mkPreludeMiscIdUnique 136
+hetmet_PGArrow_key :: Unique
+hetmet_PGArrow_key = mkPreludeMiscIdUnique 137
+hetmet_pga_id_key :: Unique
+hetmet_pga_id_key = mkPreludeMiscIdUnique 138
+hetmet_pga_comp_key :: Unique
+hetmet_pga_comp_key = mkPreludeMiscIdUnique 139
+hetmet_pga_first_key :: Unique
+hetmet_pga_first_key = mkPreludeMiscIdUnique 140
+hetmet_pga_second_key :: Unique
+hetmet_pga_second_key = mkPreludeMiscIdUnique 141
+hetmet_pga_cancell_key :: Unique
+hetmet_pga_cancell_key = mkPreludeMiscIdUnique 142
+hetmet_pga_cancelr_key :: Unique
+hetmet_pga_cancelr_key = mkPreludeMiscIdUnique 143
+hetmet_pga_uncancell_key :: Unique
+hetmet_pga_uncancell_key = mkPreludeMiscIdUnique 144
+hetmet_pga_uncancelr_key :: Unique
+hetmet_pga_uncancelr_key = mkPreludeMiscIdUnique 145
+hetmet_pga_assoc_key :: Unique
+hetmet_pga_assoc_key = mkPreludeMiscIdUnique 146
+hetmet_pga_unassoc_key :: Unique
+hetmet_pga_unassoc_key = mkPreludeMiscIdUnique 147
+hetmet_pga_copy_key :: Unique
+hetmet_pga_copy_key = mkPreludeMiscIdUnique 148
+hetmet_pga_drop_key :: Unique
+hetmet_pga_drop_key = mkPreludeMiscIdUnique 149
+hetmet_pga_swap_key :: Unique
+hetmet_pga_swap_key = mkPreludeMiscIdUnique 150
+hetmet_pga_applyl_key :: Unique
+hetmet_pga_applyl_key = mkPreludeMiscIdUnique 151
+hetmet_pga_applyr_key :: Unique
+hetmet_pga_applyr_key = mkPreludeMiscIdUnique 152
+hetmet_pga_curryl_key :: Unique
+hetmet_pga_curryl_key = mkPreludeMiscIdUnique 153
+hetmet_pga_curryr_key :: Unique
+hetmet_pga_curryr_key = mkPreludeMiscIdUnique 154
+
+
 
 ---------------- Template Haskell -------------------
 --     USES IdUniques 200-499
@@ -1374,7 +1469,7 @@ hetmet_guest_char_literal_key    = mkPreludeMiscIdUnique 136
 
 \begin{code}
 numericTyKeys :: [Unique]
-numericTyKeys = 
+numericTyKeys =
        [ wordTyConKey
        , intTyConKey
        , integerTyConKey

diff --git a/libraries/base b/libraries/base
index f643d95..e1f4f45 160000 (submodule)
--- a/libraries/base
+++ b/libraries/base
@@ -1 +1 @@
-Subproject commit f643d954e30d5ac635d3c0ff41ad40401fbd5e92
+Subproject commit e1f4f4560778857133cd778b5bc66c1074add312