Added an annotation to Grin alternatives, that it is either:

- Normal
- Ident: an alternative that just returns the scrutinee
- Reenter: an alternative that returns a value that needs to be scrutinized again

The Reenter annotation will be used in the forthcoming CaseHoist transformation,
but as it is not yet used, this commit is semantically neutral.

EHC/src/ehc/Core/ToGrin.cag

@@ -272,9 +272,9 @@ simplArgL uniq arityMp vL
 saturateAltL :: UID -> GrExpr -> GrAltL -> GrAltL
 saturateAltL uniq dflt altL
   =  case altL of
-       (GrAlt_Alt (GrPatAlt_LitInt _) _ : _)
-         | null [ a | a@(GrAlt_Alt (GrPatAlt_Otherwise) _) <- altL ]
-           -> altL ++ [GrAlt_Alt (GrPatAlt_Otherwise) dflt]
+       (GrAlt_Alt _ (GrPatAlt_LitInt _) _ : _)
+         | null [ a | a@(GrAlt_Alt _ (GrPatAlt_Otherwise) _) <- altL ]
+           -> altL ++ [GrAlt_Alt GrAltAnnNormal (GrPatAlt_Otherwise) dflt]
        _   -> altL
 %%]
 
@@ -561,7 +561,7 @@ ATTR CAlt    [ | | grAlt: GrAlt ]
 ATTR CAltL   [ | | grAltL: GrAltL ]
 
 SEM CAlt
-  | Alt         lhs         .   grAlt       =   GrAlt_Alt @pat.grPat @expr.grExpr
+  | Alt         lhs         .   grAlt       =   GrAlt_Alt GrAltAnnNormal @pat.grPat @expr.grExpr
 
 SEM CAltL
   | Cons        lhs         .   grAltL      =   @hd.grAlt : @tl.grAltL

EHC/src/ehc/GrinCode.cag

@@ -99,6 +99,30 @@ mkGrTagAnn = GrTagAnn
 emptyGrTagAnn = mkGrTagAnn 0 0
 %%]
 
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Alternative categories
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+%%[8 hs export(GrAltAnn(..))
+
+-- Annotation for Grin Alternatives
+--   Normal:  this alternative has classic semantics
+--   Ident:   this alternative just returns the scrutinee, but has classic semantics
+--   Reenter: this alternative returns a value which has to be scrutinized again against the other alternatives
+
+data GrAltAnn
+  = GrAltAnnNormal
+  | GrAltAnnIdent
+  | GrAltAnnReenter
+  deriving (Eq,Ord,Show)
+
+%%]
+
+
+
+
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %%% Misc info passed to backend
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

EHC/src/ehc/GrinCode/AbsSyn.cag

@@ -64,8 +64,10 @@ DATA GrExpr
                 handler         : GrExpr
 
 DATA GrAlt
-  | Alt         pat             : GrPatAlt
+  | Alt         ann             : {GrAltAnn}
+                pat             : GrPatAlt
                 expr            : GrExpr
+
 
 TYPE GrAltL     =   [GrAlt]
 

EHC/src/ehc/GrinCode/Parser.chs

@@ -95,7 +95,15 @@ pValL           ::   GRIParser GrValL
 pValL           =    pList pVal
 
 pAlt            ::   GRIParser GrAlt
-pAlt            =    GrAlt_Alt <$> pPatAlt <* pKey "->" <*> pCurly pExprSeq
+pAlt            =    GrAlt_Alt <$> pAltAnn <*> pPatAlt <* pKey "->" <*> pCurly pExprSeq
+
+pAltAnn         ::   GRIParser GrAltAnn
+pAltAnn         =    (    GrAltAnnNormal  <$ pKey "normal"
+                     <|>  GrAltAnnIdent   <$ pKey "ident"
+                     <|>  GrAltAnnReenter <$ pKey "reenter"
+                     <|>  pSucceed GrAltAnnNormal
+                     )
+
 
 pPatLam         ::   GRIParser GrPatLam
 pPatLam         =    GrPatLam_Var      <$> pGrNm

EHC/src/ehc/GrinCode/Pretty.cag

@@ -97,6 +97,11 @@ type PPGrNm = HsName -> PP_Doc
 ppCurlysSemisV :: [PP_Doc] -> PP_Doc
 ppCurlysSemisV pL = ppBlock "{ " "} " "; " pL
 
+ppGrAltAnn :: GrAltAnn -> PP_Doc
+ppGrAltAnn GrAltAnnNormal  = pp ""
+ppGrAltAnn GrAltAnnIdent   = pp "ident "
+ppGrAltAnn GrAltAnnReenter = pp "reenter "
+
 %%]
 ppGrNm :: PPGrNm
 ppGrNm = cfgppHsName CfgPP_Grin
@@ -150,7 +155,7 @@ SEM GrExpr
                                                 indent 2 (ppCurlysSemisV [@handler.pp])
 
 SEM GrAlt
-  | Alt         lhs         .   pp          =   @pat.pp >-< indent 2 ("->" >#< ppCurlysSemisV [@expr.pp])
+  | Alt         lhs         .   pp          =   ppGrAltAnn @ann >|< @pat.pp >-< indent 2 ("->" >#< ppCurlysSemisV [@expr.pp])
 
 SEM GrVal
   | Empty       lhs         .   pp          =   pp "()"

EHC/src/grinc/GrinCode/Trf/GrInline.cag

@@ -61,7 +61,7 @@ buildAlternative tag args arity rhsElem unique uf vf tf =
 
         uniqHead        = unique + arity
         entrHead        = zip [unique..] args
-        codeHead        = GrAlt_Alt (GrPatAlt_Node tag patNames)
+        codeHead        = GrAlt_Alt (if rhsElem==EvApTagUnit then GrAltAnnIdent else GrAltAnnNormal) (GrPatAlt_Node tag patNames)
 
         (uniqBody,
          entrBody,

EHC/src/grinc/GrinCode/Trf/LowerGrin.cag

@@ -133,7 +133,7 @@ SEM GrAlt
                                                           newNode  = GrVal_Node @pat.patTag (map snd mappings)
                                                       in  Map.fromList ((nm,newNode) : mappings)  `Map.union`  @lhs.subst
 
-               lhs . grTrf  =  GrAlt_Alt (GrPatAlt_Tag @pat.patTag) @expr.grTrf
+               lhs . grTrf  =  GrAlt_Alt @ann (GrPatAlt_Tag @pat.patTag) @expr.grTrf
 
 
 -- Perform the variable substitution

EHC/src/grinc/GrinCode/Trf/SplitFetch.cag

@@ -193,7 +193,7 @@ SEM GrAlt
          (expr.uniq, loc.renameList, loc.newExprInfo) = maybe (@lhs.uniq, [], []) id @mbExprInfo
          expr  .  renameMap  =  Map.union (Map.fromList @loc.renameList) @lhs.renameMap
          lhs   .  newVars    =  @loc.renameList
-         lhs   .  grTrf      =  GrAlt_Alt @pat.grTrf (buildSeqs @expr.grTrf @newExprInfo)
+         lhs   .  grTrf      =  GrAlt_Alt @ann @pat.grTrf (buildSeqs @expr.grTrf @newExprInfo)
 %%]
 
 %%[8.lastFetch