fixes: variant 9 compiles and runs

EHC/src/ehc/EH/GatherGam.cag

@@ -74,8 +74,10 @@ SEM Expr
                                                         @body.gathClDfGam `gamUnion` @decls.gathClDfGam
   | * - Let     lhs         .   gathClDfGam         =   emptyGam
 
+%%[[50
 SEM AGItf
   | AGItf       lhs         .   gathClDfGam         =   ehcOptTrace @lhs.opts "AGItf.lhs.gathClDfGam" @expr.gathClDfGam
+%%]]
 %%]
 
 %%[(50 hmtyinfer)

EHC/src/ehc/EH/InferClass.cag

@@ -79,19 +79,21 @@ SEM Decl
                                 .   dataDictTag     =   mkClassCTag @dataDictNm (length @clsAllFldTyL)        -- only used when `not ehcCfgClassViaRec'
                                 .   dataDictTy      =   tyDict @hdPrTy -- appConApp @dataDictNm @prClsArgTyL
                                 .   dictTag         =   if ehcCfgClassViaRec @lhs.opts then CTagRec else @dataDictTag
-                                .   clgi2           =   @clgi1 { clgiPrToEvidRecTy	= tyQuantifyClosed $ [@hdPrTy] `appArr` @clsTyRec
+                                .   clgiUpd         =   \clgi -> clgi
+                                                               { clgiPrToEvidRecTy	= tyQuantifyClosed $ [@hdPrTy] `appArr` @clsTyRec
                                                                , clgiPrToEvidDataTy = tyQuantifyClosed $ [@hdPrTy] `appArr` @dataDictTy
                                                                , clgiRuleTy         = tyQuantifyClosed @tyPrExpr.ty
                                                                , clgiDictTag        = @dictTag
                                                                -- , clgiSupClsFldNmL   = @supClsFldNmL
                                                                }
+                                .   clgi2           =   @clgiUpd @clgi1
                                 .   (dataDictConTy, dataDictConProdTy)
                                                     =   mkDataConstrTys1 (assocLElts @clsAllFldTyL, @clsAllFldTyL) @dataDictTy
                                 .   dataDictQuUnConTy
                                                     =   mkDataConstrTys2 (tvarKi @lhs.finTyKiGam @tyPrExpr.intlTyKiGam @lhs.tvKiVarMp emptyVarMp) @dataDictConProdTy @dataDictTy
                 lhs             .   patTyGam        =   gamAdd @dataDictNm (TyGamInfo (appCon @dataDictNm)) @lhs.patTyGam
                                 .   gathTySigGam    =   valGamMapTy tyQuantifyClosed @clsTySigGam
-                                .   patClGam2       =   gamAdd @clNm @clgi2 @lhs.patClGam2
+                                .   patClGam2       =   gamTopUpdate @clgiUpd @clNm @lhs.patClGam2
                                 .	patValGam		=	mkDataConstrValGam @dataDictNm @dataDictConTy @dataDictQuUnConTy `gamUnion` @lhs.patValGam
                 decls           .   gathDataGam     =   emptyGam
                 lhs             .   gathDeclDataGam =   if ehcCfgClassViaRec @lhs.opts
@@ -298,7 +300,7 @@ SEM Decl
                 				.	tyVarMp			=	@decls.patTyVarMp
                 lhs             .   patTyGam        =   @lhs.patTyGam
                                 .   gathTySigGam    =   maybe emptyGam (\(n,_) -> n `gamSingleton` ValGamInfo (tyQuantifyClosed @tyPrExpr.evTy)) @mbNmElim
-                                .   patValGam       =   gamAdd @dictNm @vgi @lhs.patValGam
+                                .   patValGam       =   gamTopUpdate (const @vgi) @dictNm @lhs.patValGam
                                 .	patTyVarMp		=	@lhs.patTyVarMp
                 loc         	.   lUniq3		  	:   UNIQUEREF gUniq
                 loc         	.   lUniq4		  	:   UNIQUEREF gUniq

EHC/src/ehc/EH/Parser.chs

@@ -510,8 +510,11 @@ pSel            =    pVar <|> pCon <|> mkHNmPos <$> pInt
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[9
+pPrExprClass'   ::   EHCParser (HsName,PrExpr)
+pPrExprClass'   =    (\c t -> (c, mkEH PrExpr_Class c t))  <$> pCon <*> pTyExprs
+
 pPrExprClass    ::   EHCParser PrExpr
-pPrExprClass    =    mkEH PrExpr_Class  <$> pCon <*> pTyExprs
+pPrExprClass    =    snd <$> pPrExprClass'
 %%]
 
 %%[9
@@ -555,17 +558,18 @@ pPrExprBase     =    pPrExprClass
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[9
-pClassHead      ::   EHCParser TyExpr
-pClassHead      =    pTyPrExprPrefix <*> pHd <|> pHd
-                where pHd = mkEH TyExpr_Pred <$> pPrExprClass
+pClassHead      ::   EHCParser (HsName,TyExpr)
+pClassHead      =    (\pre (n,hd) -> (n, pre hd)) <$> pTyPrExprPrefix <*> pHd
+                <|>  pHd
+  where pHd = (\(n,p) -> (n, mkEH TyExpr_Pred p)) <$> pPrExprClass'
 
 pDeclClass      ::   EHCParser Decl
 %%[[9
-pDeclClass      =    (\h d -> mkEH Decl_Class hsnUnknown h Nothing d)
+pDeclClass      =    (\(n,h) d -> mkEH Decl_Class n h Nothing d)
 %%][15
-pDeclClass      =    (\h deps d -> mkEH Decl_Class hsnUnknown h deps Nothing d)
+pDeclClass      =    (\(n,h) deps d -> mkEH Decl_Class n h deps Nothing d)
 %%][92
-pDeclClass      =    (\h deps d -> mkEH Decl_Class hsnUnknown h deps Nothing d [])
+pDeclClass      =    (\(n,h) deps d -> mkEH Decl_Class n h deps Nothing d [])
 %%]]
                      <$   pKey "class"
                      <*>  pClassHead
@@ -578,7 +582,7 @@ pDeclClass      =    (\h deps d -> mkEH Decl_Class hsnUnknown h deps Nothing d [
 
 pDeclInstance   ::   EHCParser Decl
 pDeclInstance   =    pKey "instance"
-                     *>   (    (\n h d -> mkEH Decl_Instance n InstNormal h d)
+                     *>   (    (\n (_,h) d -> mkEH Decl_Instance n InstNormal h d)
                                <$>  ((\n e -> Just (n,e)) <$> pVar <*> (True <$ pKey "<:" <|> False <$ pKey "::") `opt` Nothing)
                                <*>  pClassHead
                                <*   pKey "where" <*> pDecls

EHC/src/ehc/EH/Trace.cag

@@ -13,13 +13,30 @@ SEM AGItf
  | AGItf            loc     .   tr          =   trPP (`Set.member` ehcOptTraceOn @lhs.opts)
 %%]
 
-%%[9 ag
+%%[(9 hmtyinfer) ag
 SEM Decl
   | Instance        loc     .   trpp        =   (@lhs.tr TraceOn_EhClsGam $ [@dictNm >#< " = Instance" >|< ppParens @instVariant >#< @instClsNm] ++ [ "clgi=" >#< @clgi ])
                                                 >< @tyPrExpr.trpp >< @decls.trpp
+  | Class           loc     .   trpp        =   (@lhs.tr TraceOn_EhClsGam $ [@clNm >#< " = Class"] ++ [ "clgi1=" >#< @clgi1, "clgi2=" >#< @clgi2, "patClGam2=" >#< ppGam @lhs.patClGam2 ])
+                                                >< @tyPrExpr.trpp
+%%[[15
+                                                >< @funcDeps.trpp
+%%]]
+                                                >< @decls.trpp
+%%[[92
+                                                -- >< @generDerivs.trpp
+%%]]
 %%]
 
 %%[(5 hmtyinfer)
 SEM PatExpr
-  | Con        		loc     .   trpp        =   (@lhs.tr TraceOn_EhValGam $ ["PatExpr.Con" >#< hsnUn @nm] ++ [ "ty_g_=" >#< ppTy @ty_g_, "@lhs.patTyVarMp |=> ty_g_=" >#< ppTy (@lhs.patTyVarMp `varUpd` @ty_g_), "patFunTy=" >#< ppTy @patFunTy ])
+  | Con             loc     .   trpp        =   (@lhs.tr TraceOn_EhValGam $ ["PatExpr.Con" >#< hsnUn @nm] ++ [ "ty_g_=" >#< ppTy @ty_g_, "@lhs.patTyVarMp |=> ty_g_=" >#< ppTy (@lhs.patTyVarMp `varUpd` @ty_g_), "patFunTy=" >#< ppTy @patFunTy ])
+%%]
+
+ATTR AllTyExpr [ | | clNmS USE {`Set.union`} {Set.empty}: HsNameS  clMissNmS USE {`Set.union`} {Set.empty}: HsNameS ]
+
+%%[(9 hmtyinfer)
+SEM PrExpr
+  | Class           loc     .   trpp        =   (@lhs.tr TraceOn_EhClsGam $ ["Class" >#< @nm] ++ [ "clGam=" >#< ppGam @lhs.clGam ])
+                                                >< @tyExprs.trpp
 %%]

EHC/src/ehc/EHC/CompilePhase/TopLevelPhases.chs

@@ -1152,8 +1152,8 @@ cpEhcCoreGrinPerModuleDoneNoFullProgAnalysis opts isMainMod isTopMod doMkExec mo
 %%]]
 %%[[(99 grin)
              , cpCleanupGrin [modNm]
-             , cpProcessAfterGrin modNm
 %%]]
+             , cpProcessAfterGrin modNm
              ]
           ++ (if not isMainMod || doMkExec
               then let how = if doMkExec then FinalCompile_Exec else FinalCompile_Module

EHC/src/ehc/Gam/Base.chs

@@ -124,6 +124,13 @@ gamTop                              = sgamTop
 {-# INLINE gamTop #-}
 %%]
 
+%%[8 export(gamTopUpdate)
+-- | Update top entries, all duplicates
+gamTopUpdate :: Ord k => (v -> v) -> k -> Gam k v -> Gam k v
+gamTopUpdate upd = sgamAlterDupOnTop $ maybe Nothing (Just . upd)
+{-# INLINE gamTopUpdate #-}
+%%]
+
 %%[8 export(gamMetaLevSingleton)
 gamMetaLevSingleton                        = sgamMetaLevSingleton
 {-# INLINE gamMetaLevSingleton #-}

EHC/src/ehc/Gam/DataGam.chs

@@ -25,7 +25,7 @@
 %%]
 %%[(7 hmtyinfer) import(qualified Data.Set as Set)
 %%]
-%%[(90 hmtyinfer) import(Data.Maybe)
+%%[(7 hmtyinfer) import(Data.Maybe)
 %%]
 
 %%[(7 hmtyinfer) import({%{EH}VarMp},{%{EH}Substitutable})

EHC/src/rts/rts.cc

@@ -338,6 +338,16 @@ int main_GB_Run(int argc, char** argv, GB_BytePtr initPC, GB_Word initCAF)
 			IF_GB_TR_ON(3,{gb_prTOSAsInt() ;printf( "\n" ) ;})
 #		endif
 	}
+%%[[8
+	// show TOS as result
+	if ( GB_Word_IsPtr( GB_TOS ) ) {
+		gb_prWord( GB_TOS ) ;
+	} else {
+		gb_prTOSAsInt() ;
+	}
+	printf( "\n" ) ;
+%%][99
+%%]]
 	GB_GCSafe_Leave ;
 	return 0 ;
 }

EHC/test/regress/9/eq-overl1.eh

@@ -1,11 +1,11 @@
-let  data Bool = False | True
-in   let  class Eq a where
-            eq :: a -> a -> Bool
-          instance dEqInt1 <: Eq Int where
-            eq = \_ _ -> True
-          instance dEqInt2 <: Eq Int where
-            eq = \_ _ -> False
-     in   let  f :: Eq a => a -> a -> Eq b => b -> b -> (Bool,Bool)
-               f = \p q r s -> (eq p q, eq r s)
-          in   let  v = f 3 4 5 6
-               in   v
+let  data Bool = False | True in
+let  class Eq a where
+       eq :: a -> a -> Bool in
+let  instance dEqInt1 <: Eq Int where
+       eq = \_ _ -> True
+     instance dEqInt2 :: Eq Int where
+       eq = \_ _ -> False
+in   let  f :: Eq a => a -> a -> Eq b => b -> b -> (Bool,Bool)
+          f = \p q r s -> (eq p q, eq r s)
+     in   let  v = f 3 4 5 6
+          in   v

EHC/test/regress/99/LocalInstance2.hs

@@ -10,7 +10,7 @@ main
   = do let i = [4 :: Int, 3]
            j = [4 :: Int, 5]
        putStrLn (show (i == j))
-       putStrLn (show (let instance Eq a => Eq [a] where
+       putStrLn (show (let instance dLocInstEqA <: Eq a => Eq [a] where
                              (x:_) == (y:_) = x == y
                        in  i == j
                       ))