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, ...@@ -12,23 +12,23 @@ module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
#include "HsVersions.h" #include "HsVersions.h"
import Outputable import Outputable
import Name ( Name, getName, mkSysLocalName ) import Name ( Name, getName )
import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe,
idPrimRep, mkSysLocal, idName ) idPrimRep, mkSysLocal, idName )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL ) nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM, import FiniteMap ( FiniteMap, addListToFM, listToFM,
addToFM, lookupFM, fmToList, plusFM ) addToFM, lookupFM, fmToList )
import CoreSyn import CoreSyn
import PprCore ( pprCoreExpr ) import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep ) import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) ) import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp(..) ) import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars ) import CoreFVs ( freeVars )
import Type ( typePrimRep ) import Type ( typePrimRep, splitTyConApp_maybe )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
dataConWrapId, isUnboxedTupleCon ) dataConWrapId, isUnboxedTupleCon )
import TyCon ( TyCon, tyConFamilySize ) import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons )
import Class ( Class, classTyCon ) import Class ( Class, classTyCon )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
import Var ( isTyVar ) import Var ( isTyVar )
...@@ -46,7 +46,7 @@ import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, ...@@ -46,7 +46,7 @@ import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
ClosureEnv, HValue, filterNameMap, ClosureEnv, HValue, filterNameMap,
iNTERP_STACK_CHECK_THRESH ) iNTERP_STACK_CHECK_THRESH )
import List ( intersperse, sortBy ) import List ( intersperse, sortBy, zip4 )
import Foreign ( Ptr(..), mallocBytes ) import Foreign ( Ptr(..), mallocBytes )
import Addr ( Addr(..), addrToInt, writeCharOffAddr ) import Addr ( Addr(..), addrToInt, writeCharOffAddr )
import CTypes ( CInt ) import CTypes ( CInt )
...@@ -261,10 +261,10 @@ schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList ...@@ -261,10 +261,10 @@ schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
-- Delegate tail-calls to schemeT. -- Delegate tail-calls to schemeT.
schemeE d s p e@(fvs, AnnApp f a) 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) schemeE d s p e@(fvs, AnnVar v)
| isFollowableRep v_rep | isFollowableRep v_rep
= returnBc (schemeT d s p (fvs, AnnVar v)) = schemeT d s p (fvs, AnnVar v)
| otherwise | otherwise
= -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
...@@ -398,7 +398,14 @@ schemeE d s p other ...@@ -398,7 +398,14 @@ schemeE d s p other
(pprCoreExpr (deAnnotate 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 -- 1. A nullary constructor. Push its closure on the stack
-- and SLIDE and RETURN. -- and SLIDE and RETURN.
...@@ -414,74 +421,106 @@ schemeT :: Int -- Stack depth ...@@ -414,74 +421,106 @@ schemeT :: Int -- Stack depth
-> Sequel -- Sequel depth -> Sequel -- Sequel depth
-> BCEnv -- stack env -> BCEnv -- stack env
-> AnnExpr Id VarSet -> AnnExpr Id VarSet
-> BCInstrList -> BcM BCInstrList
schemeT d s p app schemeT d s p app
-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False -- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
-- = panic "schemeT ?!?!" -- = 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 -- Handle case 1
| is_con_call && null args_r_to_l | is_con_call && null args_r_to_l
= (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s)) = returnBc (
`snocOL` ENTER (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
`snocOL` ENTER
)
-- Cases 2 and 3 -- Cases 2 and 3
| otherwise | otherwise
= if is_con_call && isUnboxedTupleCon con = if is_con_call && isUnboxedTupleCon con
then unboxedTupleException then returnBc unboxedTupleException
else code else returnBc code
where where
-- Extract the args (R->L) and fn -- Detect and extract relevant info for the tagToEnum kludge.
(args_r_to_l_raw, fn) = chomp app maybe_is_tagToEnum_call
chomp expr = let extract_constr_Names ty
= case snd expr of = case splitTyConApp_maybe ty of
AnnVar v -> ([], v) (Just (tyc, [])) | isDataTyCon tyc
AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f) -> map getName (tyConDataCons tyc)
AnnNote n e -> chomp e other
other -> pprPanic "schemeT" -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
(ppr (deAnnotate (panic "schemeT.chomp", other))) 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
= case snd expr of
AnnVar v -> ([], v)
AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f)
AnnNote n e -> chomp e
other -> pprPanic "schemeT"
(ppr (deAnnotate (panic "schemeT.chomp", other)))
args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw
isTypeAtom (AnnType _) = True isTypeAtom (AnnType _) = True
isTypeAtom _ = False isTypeAtom _ = False
-- decide if this is a constructor call, and rearrange -- decide if this is a constructor call, and rearrange
-- args appropriately. -- args appropriately.
maybe_dcon = isDataConId_maybe fn maybe_dcon = isDataConId_maybe fn
is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
(Just con) = maybe_dcon (Just con) = maybe_dcon
args_final_r_to_l args_final_r_to_l
| not is_con_call | not is_con_call
= args_r_to_l = args_r_to_l
| otherwise | otherwise
= filter (not.isPtr) args_r_to_l ++ filter isPtr args_r_to_l = filter (not.isPtr) args_r_to_l ++ filter isPtr args_r_to_l
where isPtr = isFollowableRep . atomRep where isPtr = isFollowableRep . atomRep
-- make code to push the args and then do the SLIDE-ENTER thing -- make code to push the args and then do the SLIDE-ENTER thing
code = do_pushery d args_final_r_to_l code = do_pushery d args_final_r_to_l
tag_when_push = not is_con_call tag_when_push = not is_con_call
narg_words = sum (map (get_arg_szw . atomRep) args_r_to_l) narg_words = sum (map (get_arg_szw . atomRep) args_r_to_l)
get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW
do_pushery d (arg:args) do_pushery d (arg:args)
= let (push, arg_words) = pushAtom tag_when_push d p arg = let (push, arg_words) = pushAtom tag_when_push d p arg
in push `appOL` do_pushery (d+arg_words) args in push `appOL` do_pushery (d+arg_words) args
do_pushery d [] do_pushery d []
= case maybe_dcon of = case maybe_dcon of
Just con -> PACK con narg_words `consOL` ( Just con -> PACK con narg_words `consOL` (
mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER) mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
Nothing Nothing
-> let (push, arg_words) = pushAtom True d p (AnnVar fn) -> let (push, arg_words) = pushAtom True d p (AnnVar fn)
in push in push
`appOL` mkSLIDE (narg_words+arg_words) `appOL` mkSLIDE (narg_words+arg_words)
(d - s - narg_words) (d - s - narg_words)
`snocOL` ENTER `snocOL` ENTER
mkSLIDE n d mkSLIDE n d
= if d == 0 then nilOL else unitOL (SLIDE n d) = if d == 0 then nilOL else unitOL (SLIDE n d)
bind x f
= f x
atomRep (AnnVar v) = typePrimRep (idType v) atomRep (AnnVar v) = typePrimRep (idType v)
atomRep (AnnLit l) = literalPrimRep l atomRep (AnnLit l) = literalPrimRep l
...@@ -491,6 +530,29 @@ atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) ...@@ -491,6 +530,29 @@ atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) 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, -- Make code to unpack the top-of-stack constructor onto the stack,
-- adding tags for the unboxed bits. Takes the PrimReps of the -- adding tags for the unboxed bits. Takes the PrimReps of the
-- constructor's arguments. off_h and off_s are travelling offsets -- constructor's arguments. off_h and off_s are travelling offsets
...@@ -905,4 +967,9 @@ getLabelBc :: BcM Int ...@@ -905,4 +967,9 @@ getLabelBc :: BcM Int
getLabelBc st getLabelBc st
= (nextlabel st, st{nextlabel = 1 + nextlabel 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} \end{code}
...@@ -87,6 +87,8 @@ data BCInstr ...@@ -87,6 +87,8 @@ data BCInstr
| TESTEQ_P Int LocalLabel | TESTEQ_P Int LocalLabel
| CASEFAIL | CASEFAIL
| JMP LocalLabel
-- To Infinity And Beyond -- To Infinity And Beyond
| ENTER | ENTER
| RETURN PrimRep | RETURN PrimRep
...@@ -132,6 +134,7 @@ instance Outputable BCInstr where ...@@ -132,6 +134,7 @@ instance Outputable BCInstr where
ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab 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 (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 (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
ppr (JMP lab) = text "JMP" <+> int lab
ppr CASEFAIL = text "CASEFAIL" ppr CASEFAIL = text "CASEFAIL"
ppr ENTER = text "ENTER" ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN pk) = text "RETURN " <+> ppr pk
...@@ -162,6 +165,7 @@ bciStackUse (TESTEQ_D d lab) = 0 ...@@ -162,6 +165,7 @@ bciStackUse (TESTEQ_D d lab) = 0
bciStackUse (TESTLT_P i lab) = 0 bciStackUse (TESTLT_P i lab) = 0
bciStackUse (TESTEQ_P i lab) = 0 bciStackUse (TESTEQ_P i lab) = 0
bciStackUse CASEFAIL = 0 bciStackUse CASEFAIL = 0
bciStackUse (JMP lab) = 0
bciStackUse ENTER = 0 bciStackUse ENTER = 0
bciStackUse (RETURN pk) = 0 bciStackUse (RETURN pk) = 0
......
...@@ -250,6 +250,7 @@ mkBits findLabel st proto_insns ...@@ -250,6 +250,7 @@ mkBits findLabel st proto_insns
TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l) TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l) TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
CASEFAIL -> instr1 st i_CASEFAIL CASEFAIL -> instr1 st i_CASEFAIL
JMP l -> instr2 st i_JMP (findLabel l)
ENTER -> instr1 st i_ENTER ENTER -> instr1 st i_ENTER
RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
instr2 st2 i_RETURN itbl_no instr2 st2 i_RETURN itbl_no
...@@ -376,6 +377,7 @@ instrSize16s instr ...@@ -376,6 +377,7 @@ instrSize16s instr
TESTEQ_D _ _ -> 3 TESTEQ_D _ _ -> 3
TESTLT_P _ _ -> 3 TESTLT_P _ _ -> 3
TESTEQ_P _ _ -> 3 TESTEQ_P _ _ -> 3
JMP _ -> 2
CASEFAIL -> 1 CASEFAIL -> 1
ENTER -> 1 ENTER -> 1
RETURN _ -> 2 RETURN _ -> 2
...@@ -587,6 +589,7 @@ i_CASEFAIL = (bci_CASEFAIL :: Int) ...@@ -587,6 +589,7 @@ i_CASEFAIL = (bci_CASEFAIL :: Int)
i_ENTER = (bci_ENTER :: Int) i_ENTER = (bci_ENTER :: Int)
i_RETURN = (bci_RETURN :: Int) i_RETURN = (bci_RETURN :: Int)
i_STKCHECK = (bci_STKCHECK :: Int) i_STKCHECK = (bci_STKCHECK :: Int)
i_JMP = (bci_JMP :: Int)
iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: 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