[project @ 2001-03-21 11:17:00 by sewardj]

Implement tagToEnum# for the bytecode system.  Blargh.  We spot tail-calls
   tagToEnum# <type> arg
and emit code to push the arg, then do a bytecode test-sequence to
determine what value it is, push the relevant constructor, and merge
control flow again, at a label which does the normal tail-call
sequence: slide the constructor down to the sequel and enter it.

Blargyle, or as some would say, barferama.

ghc/compiler/ghci/ByteCodeGen.lhs

@@ -12,23 +12,23 @@ module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
 #include "HsVersions.h"
 
 import Outputable
-import Name		( Name, getName, mkSysLocalName )
+import Name		( Name, getName )
 import Id		( Id, idType, isDataConId_maybe, isPrimOpId_maybe,
 			  idPrimRep, mkSysLocal, idName )
 import OrdList		( OrdList, consOL, snocOL, appOL, unitOL, 
 			  nilOL, toOL, concatOL, fromOL )
 import FiniteMap	( FiniteMap, addListToFM, listToFM,
-			  addToFM, lookupFM, fmToList, plusFM )
+			  addToFM, lookupFM, fmToList )
 import CoreSyn
 import PprCore		( pprCoreExpr )
 import Literal		( Literal(..), literalPrimRep )
 import PrimRep		( PrimRep(..) )
 import PrimOp		( PrimOp(..)  )
 import CoreFVs		( freeVars )
-import Type		( typePrimRep )
+import Type		( typePrimRep, splitTyConApp_maybe )
 import DataCon		( dataConTag, fIRST_TAG, dataConTyCon, 
                           dataConWrapId, isUnboxedTupleCon )
-import TyCon		( TyCon, tyConFamilySize )
+import TyCon		( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons )
 import Class		( Class, classTyCon )
 import Util		( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
 import Var		( isTyVar )
@@ -46,7 +46,7 @@ import ByteCodeLink	( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
 			  ClosureEnv, HValue, filterNameMap,
 			  iNTERP_STACK_CHECK_THRESH )
 
-import List		( intersperse, sortBy )
+import List		( intersperse, sortBy, zip4 )
 import Foreign		( Ptr(..), mallocBytes )
 import Addr		( Addr(..), addrToInt, writeCharOffAddr )
 import CTypes		( CInt )
@@ -261,10 +261,10 @@ schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
 
 -- Delegate tail-calls to schemeT.
 schemeE d s p e@(fvs, AnnApp f a) 
-   = returnBc (schemeT d s p (fvs, AnnApp f a))
+   = schemeT d s p (fvs, AnnApp f a)
 schemeE d s p e@(fvs, AnnVar v)
    | isFollowableRep v_rep
-   = returnBc (schemeT d s p (fvs, AnnVar v))
+   = schemeT d s p (fvs, AnnVar v)
 
    | otherwise
    = -- returning an unboxed value.  Heave it on the stack, SLIDE, and RETURN.
@@ -398,7 +398,14 @@ schemeE d s p other
                (pprCoreExpr (deAnnotate other))
 
 
--- Compile code to do a tail call.  Three cases:
+-- Compile code to do a tail call.  Specifically, push the fn,
+-- slide the on-stack app back down to the sequel depth,
+-- and enter.  Four cases:
+--
+-- 0.  (Nasty hack).
+--     An application "PrelGHC.tagToEnum# <type> unboxed-int".
+--     The int will be on the stack.  Generate a code sequence
+--     to convert it to the relevant constructor, SLIDE and ENTER.
 --
 -- 1.  A nullary constructor.  Push its closure on the stack 
 --     and SLIDE and RETURN.
@@ -414,24 +421,53 @@ schemeT :: Int 		-- Stack depth
         -> Sequel 	-- Sequel depth
         -> BCEnv 	-- stack env
         -> AnnExpr Id VarSet 
-        -> BCInstrList
+        -> BcM BCInstrList
 
 schemeT d s p app
 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
 --   = panic "schemeT ?!?!"
 
+   -- Handle case 0
+   | Just (arg, constr_names) <- maybe_is_tagToEnum_call
+   = pushAtom True d p arg 		`bind` \ (push, arg_words) ->
+     implement_tagToId constr_names	`thenBc` \ tagToId_sequence ->
+     returnBc (push `appOL`  tagToId_sequence            
+                    `appOL`  mkSLIDE 1 (d+arg_words-s)
+                    `snocOL` ENTER)
+
    -- Handle case 1
    | is_con_call && null args_r_to_l
-   = (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
+   = returnBc (
+        (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
         `snocOL` ENTER
+     )
 
    -- Cases 2 and 3
    | otherwise
    = if   is_con_call && isUnboxedTupleCon con
-     then unboxedTupleException
-     else code
+     then returnBc unboxedTupleException
+     else returnBc code
 
    where
+      -- Detect and extract relevant info for the tagToEnum kludge.
+      maybe_is_tagToEnum_call
+         = let extract_constr_Names ty
+                  = case splitTyConApp_maybe ty of
+                       (Just (tyc, [])) |  isDataTyCon tyc
+                                        -> map getName (tyConDataCons tyc)
+                       other
+                          -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+           in 
+           case app of
+              (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
+                 -> case isPrimOpId_maybe v of
+                       Nothing -> Nothing
+                       Just primop |  primop == TagToEnumOp
+                                   -> Just (snd arg, extract_constr_Names t)
+                                   |  otherwise
+                                   -> Nothing
+              other -> Nothing
+
       -- Extract the args (R->L) and fn
       (args_r_to_l_raw, fn) = chomp app
       chomp expr
@@ -482,6 +518,9 @@ schemeT d s p app
 
 mkSLIDE n d 
    = if d == 0 then nilOL else unitOL (SLIDE n d)
+bind x f 
+   = f x
+
 
 atomRep (AnnVar v)    = typePrimRep (idType v)
 atomRep (AnnLit l)    = literalPrimRep l
@@ -491,6 +530,29 @@ atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 
 
+-- Compile code which expects an unboxed Int on the top of stack,
+-- (call it i), and pushes the i'th closure in the supplied list 
+-- as a consequence.
+implement_tagToId :: [Name] -> BcM BCInstrList
+implement_tagToId names
+   = ASSERT(not (null names))
+     getLabelsBc (length names)			`thenBc` \ labels ->
+     getLabelBc					`thenBc` \ label_fail ->
+     getLabelBc 				`thenBc` \ label_exit ->
+     zip4 labels (tail labels ++ [label_fail])
+                 [0 ..] names			`bind`   \ infos ->
+     map (mkStep label_exit) infos		`bind`   \ steps ->
+     returnBc (concatOL steps
+               `appOL` 
+               toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
+     where
+        mkStep l_exit (my_label, next_label, n, name_for_n)
+           = toOL [LABEL my_label, 
+                   TESTEQ_I n next_label, 
+                   PUSH_G (Left name_for_n), 
+                   JMP l_exit]
+
+
 -- Make code to unpack the top-of-stack constructor onto the stack, 
 -- adding tags for the unboxed bits.  Takes the PrimReps of the 
 -- constructor's arguments.  off_h and off_s are travelling offsets
@@ -905,4 +967,9 @@ getLabelBc :: BcM Int
 getLabelBc st
    = (nextlabel st, st{nextlabel = 1 + nextlabel st})
 
+getLabelsBc :: Int -> BcM [Int]
+getLabelsBc n st
+   = let ctr = nextlabel st 
+     in  ([ctr .. ctr+n-1], st{nextlabel = ctr+n})
+
 \end{code}

ghc/compiler/ghci/ByteCodeInstr.lhs

@@ -87,6 +87,8 @@ data BCInstr
    | TESTEQ_P  Int    LocalLabel
 
    | CASEFAIL
+   | JMP              LocalLabel
+
    -- To Infinity And Beyond
    | ENTER
    | RETURN	PrimRep
@@ -132,6 +134,7 @@ instance Outputable BCInstr where
    ppr (TESTEQ_D  d lab)     = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
    ppr (TESTLT_P  i lab)     = text "TESTLT_P" <+> int i <+> text "__" <> int lab
    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
+   ppr (JMP lab)             = text "JMP"      <+> int lab
    ppr CASEFAIL              = text "CASEFAIL"
    ppr ENTER                 = text "ENTER"
    ppr (RETURN pk)           = text "RETURN  " <+> ppr pk
@@ -162,6 +165,7 @@ bciStackUse (TESTEQ_D  d lab)     = 0
 bciStackUse (TESTLT_P  i lab)     = 0
 bciStackUse (TESTEQ_P  i lab)     = 0
 bciStackUse CASEFAIL              = 0
+bciStackUse (JMP lab)             = 0
 bciStackUse ENTER                 = 0
 bciStackUse (RETURN pk)           = 0
 

ghc/compiler/ghci/ByteCodeLink.lhs

@@ -250,6 +250,7 @@ mkBits findLabel st proto_insns
                TESTLT_P  i l      -> instr3 st i_TESTLT_P i (findLabel l)
                TESTEQ_P  i l      -> instr3 st i_TESTEQ_P i (findLabel l)
                CASEFAIL           -> instr1 st i_CASEFAIL
+               JMP l              -> instr2 st i_JMP (findLabel l)
                ENTER              -> instr1 st i_ENTER
                RETURN rep         -> do (itbl_no,st2) <- itoc_itbl st rep
                                         instr2 st2 i_RETURN itbl_no
@@ -376,6 +377,7 @@ instrSize16s instr
         TESTEQ_D _ _   -> 3
         TESTLT_P _ _   -> 3
         TESTEQ_P _ _   -> 3
+        JMP      _     -> 2
         CASEFAIL       -> 1
         ENTER          -> 1
         RETURN   _     -> 2
@@ -587,6 +589,7 @@ i_CASEFAIL = (bci_CASEFAIL :: Int)
 i_ENTER    = (bci_ENTER :: Int)
 i_RETURN   = (bci_RETURN :: Int)
 i_STKCHECK = (bci_STKCHECK :: Int)
+i_JMP      = (bci_JMP :: Int)
 
 iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)