Commit 7c98178c authored by sewardj's avatar sewardj

[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.
parent 44f0f21f
......@@ -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}
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment