add support for flattening recursive-let

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index c8f6390..2e51823 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -123,6 +123,8 @@ deSugar hsc_env
                                     , undefined
                                     , undefined
                                     , undefined
                                     , undefined
                                     , undefined
                                     , undefined

+                                    , undefined
+                                    , undefined

                                ))
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
                                ))
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)

@@ -165,6 +167,8 @@ deSugar hsc_env
                           ; 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
                           ; 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

+                          ; hetmet_pga_loopl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopl_name else return undefined
+                          ; hetmet_pga_loopr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopr_name else return undefined

                           ; let hpc_init
                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
                           ; let hpc_init
                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty

@@ -197,6 +201,8 @@ deSugar hsc_env
                                    , hetmet_pga_applyr
                                    , hetmet_pga_curryl
                                    , hetmet_pga_curryr
                                    , hetmet_pga_applyr
                                    , hetmet_pga_curryl
                                    , hetmet_pga_curryr

+                                   , hetmet_pga_loopl
+                                   , hetmet_pga_loopr

                                    ) }
 
         ; case mb_res of {
                                    ) }
 
         ; case mb_res of {

@@ -226,7 +232,10 @@ deSugar hsc_env
                                    , hetmet_pga_applyl
                                    , hetmet_pga_applyr
                                    , hetmet_pga_curryl
                                    , hetmet_pga_applyl
                                    , hetmet_pga_applyr
                                    , hetmet_pga_curryl

-                                   , hetmet_pga_curryr) -> do
+                                   , hetmet_pga_curryr
+                                   , hetmet_pga_loopl
+                                   , hetmet_pga_loopr
+                                   ) -> do

 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var

@@ -288,7 +297,10 @@ deSugar hsc_env
                                              hetmet_pga_applyl
                                              hetmet_pga_applyr
                                              hetmet_pga_curryl
                                              hetmet_pga_applyl
                                              hetmet_pga_applyr
                                              hetmet_pga_curryl

-                                             hetmet_pga_curryr)
+                                             hetmet_pga_curryr
+                                             hetmet_pga_loopl
+                                             hetmet_pga_loopr
+                                        )

                                }
                        else return final_pgm
 
                                }
                        else return final_pgm
 

diff --git a/compiler/hetmet b/compiler/hetmet
index 0f137f4..3282a2b 160000 (submodule)
--- a/compiler/hetmet
+++ b/compiler/hetmet
@@ -1 +1 @@
-Subproject commit 0f137f4fbe7076b7a0f6b33d661b4f7aa8b4f160
+Subproject commit 3282a2b78028238987a5a49e59d8e8d495aea0e1

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 4bbb479..f84f0a4 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -238,6 +238,8 @@ basicKnownKeyNames
         hetmet_pga_applyr_name,
         hetmet_pga_curryl_name,
         hetmet_pga_curryr_name,
         hetmet_pga_applyr_name,
         hetmet_pga_curryl_name,
         hetmet_pga_curryr_name,

+        hetmet_pga_loopl_name,
+        hetmet_pga_loopr_name,

 
         -- Annotation type checking
         toAnnotationWrapperName
 
         -- Annotation type checking
         toAnnotationWrapperName

@@ -971,6 +973,10 @@ 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
 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

+hetmet_pga_loopl_name :: Name
+hetmet_pga_loopl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_loopl") hetmet_pga_loopl_key
+hetmet_pga_loopr_name :: Name
+hetmet_pga_loopr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_loopr") hetmet_pga_loopr_key

 
 -- IO things
 ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
 
 -- IO things
 ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,

@@ -1643,6 +1649,11 @@ hetmet_brak_key    = mkPreludeMiscIdUnique 161
 hetmet_esc_key     = mkPreludeMiscIdUnique 162
 hetmet_csp_key     = mkPreludeMiscIdUnique 163
 
 hetmet_esc_key     = mkPreludeMiscIdUnique 162
 hetmet_csp_key     = mkPreludeMiscIdUnique 163
 

+hetmet_pga_loopl_key :: Unique
+hetmet_pga_loopl_key = mkPreludeMiscIdUnique 164
+hetmet_pga_loopr_key :: Unique
+hetmet_pga_loopr_key = mkPreludeMiscIdUnique 165
+

 
 ---------------- Template Haskell -------------------
 --     USES IdUniques 200-499
 
 ---------------- Template Haskell -------------------
 --     USES IdUniques 200-499

diff --git a/libraries/base b/libraries/base
index a166b10..9404945 160000 (submodule)
--- a/libraries/base
+++ b/libraries/base
@@ -1 +1 @@
-Subproject commit a166b102f16b45e2116f84f01fed840b981d3d40
+Subproject commit 9404945188d8f4e4daf851c0bc53a61c80b8fdfc