\begin{code}
module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
filterNameMap,
- byteCodeGen, coreExprToBCOs,
- linkIModules, linkIExpr
+ byteCodeGen, coreExprToBCOs
) where
#include "HsVersions.h"
import Outputable
import Name ( Name, getName, mkSysLocalName )
-import Id ( Id, idType, isDataConId_maybe, mkVanillaId )
+import Id ( Id, idType, isDataConId_maybe, mkVanillaId,
+ isPrimOpId_maybe, idPrimRep )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) )
+import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
import Type ( typePrimRep )
-import DataCon ( dataConTag, fIRST_TAG, dataConTyCon )
+import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
+ dataConWrapId, isUnboxedTupleCon )
import TyCon ( TyCon, tyConFamilySize )
import Class ( Class, classTyCon )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
import ErrUtils ( showPass, dumpIfSet_dyn )
import Unique ( mkPseudoUnique3 )
import FastString ( FastString(..) )
+import Panic ( GhcException(..) )
import PprType ( pprType )
-import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO )
+import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
import ByteCodeItbls ( ItblEnv, mkITbls )
import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, linkSomeBCOs, filterNameMap )
+ ClosureEnv, HValue, filterNameMap,
+ iNTERP_STACK_CHECK_THRESH )
-import List ( intersperse )
+import List ( intersperse, sortBy )
import Foreign ( Ptr(..), mallocBytes )
-import Addr ( addrToInt, writeCharOffAddr )
+import Addr ( Addr(..), addrToInt, writeCharOffAddr )
import CTypes ( CInt )
+import Exception ( throwDyn )
import PrelBase ( Int(..) )
-import PrelAddr ( Addr(..) )
import PrelGHC ( ByteArray# )
import IOExts ( unsafePerformIO )
import PrelIOBase ( IO(..) )
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
final_state = runBc (BcM_State [] 0)
- (mapBc schemeR flatBinds `thenBc_` returnBc ())
+ (mapBc (schemeR True) flatBinds
+ `thenBc_` returnBc ())
(BcM_State proto_bcos final_ctr) = final_state
dumpIfSet_dyn dflags Opt_D_dump_BCOs
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
- let invented_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level")
- let invented_id = mkVanillaId invented_name (panic "invented_id's type")
+ let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0)
+ (panic "invented_id's type")
+ let invented_name = idName invented_id
let (BcM_State all_proto_bcos final_ctr)
= runBc (BcM_State [] 0)
- (schemeR (invented_id, freeVars expr))
+ (schemeR True (invented_id, freeVars expr))
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
root_bco <- assembleBCO root_proto_bco
return (root_bco, auxiliary_bcos)
-
-
--- Linking stuff
-linkIModules :: ItblEnv -- incoming global itbl env; returned updated
- -> ClosureEnv -- incoming global closure env; returned updated
- -> [([UnlinkedBCO], ItblEnv)]
- -> IO ([HValue], ItblEnv, ClosureEnv)
-linkIModules gie gce mods
- = do let (bcoss, ies) = unzip mods
- bcos = concat bcoss
- final_gie = foldr plusFM gie ies
- (final_gce, linked_bcos) <- linkSomeBCOs final_gie gce bcos
- return (linked_bcos, final_gie, final_gce)
-
-
-linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
- -> IO HValue -- IO BCO# really
-linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
- = do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos
- (_, [root_bco]) <- linkSomeBCOs ie aux_ce [root_ul_bco]
- return root_bco
\end{code}
%************************************************************************
-- to mess with it after each push/pop.
type BCEnv = FiniteMap Id Int -- To find vars on the stack
+ppBCEnv :: BCEnv -> SDoc
+ppBCEnv p
+ = text "begin-env"
+ $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
+ $$ text "end-env"
+ where
+ pp_one (var, offset) = int offset <> colon <+> ppr var
+ cmp_snd x y = compare (snd x) (snd y)
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO nm instrs_ordlist origin
- = ProtoBCO nm (id {-peep-} (fromOL instrs_ordlist)) origin
+ = ProtoBCO nm maybe_with_stack_check origin
where
+ -- Overestimate the stack usage (in words) of this BCO,
+ -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
+ -- stack check. (The interpreter always does a stack check
+ -- for iNTERP_STACK_CHECK_THRESH words at the start of each
+ -- BCO anyway, so we only need to add an explicit on in the
+ -- (hopefully rare) cases when the (overestimated) stack use
+ -- exceeds iNTERP_STACK_CHECK_THRESH.
+ maybe_with_stack_check
+ | stack_overest >= 65535
+ = pprPanic "mkProtoBCO: stack use won't fit in 16 bits"
+ (int stack_overest)
+ | stack_overest >= iNTERP_STACK_CHECK_THRESH
+ = (STKCHECK stack_overest) : peep_d
+ | otherwise
+ = peep_d -- the supposedly common case
+
+ stack_overest = sum (map bciStackUse peep_d)
+ + 10 {- just to be really really sure -}
+
+
+ -- Merge local pushes
+ peep_d = peep (fromOL instrs_ordlist)
+
peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
= PUSH_LLL off1 (off2-1) (off3-2) : peep rest
peep (PUSH_L off1 : PUSH_L off2 : rest)
- = PUSH_LL off1 off2 : peep rest
+ = PUSH_LL off1 (off2-1) : peep rest
peep (i:rest)
= i : peep rest
peep []
-- Compile code for the right hand side of a let binding.
-- Park the resulting BCO in the monad. Also requires the
-- variable to which this value was bound, so as to give the
--- resulting BCO a name.
-schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
-schemeR (nm, rhs)
+-- resulting BCO a name. Bool indicates top-levelness.
+
+schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM ()
+schemeR is_top (nm, rhs)
{-
| trace (showSDoc (
(char ' '
= undefined
-}
| otherwise
- = schemeR_wrk rhs nm (collect [] rhs)
+ = schemeR_wrk is_top rhs nm (collect [] rhs)
collect xs (_, AnnNote note e)
collect xs not_lambda
= (reverse xs, not_lambda)
-schemeR_wrk original_body nm (args, body)
+schemeR_wrk is_top original_body nm (args, body)
+ | Just dcon <- maybe_toplevel_null_con_rhs
+ = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) (
+ emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
+ (Right original_body))
+ --)
+
+ | otherwise
= let fvs = filter (not.isTyVar) (varSetElems (fst original_body))
- all_args = reverse args ++ fvs --ORIG: fvs ++ reverse args
+ all_args = reverse args ++ fvs
szsw_args = map taggedIdSizeW all_args
szw_args = sum szsw_args
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
- argcheck = --if null args then nilOL else
- unitOL (ARGCHECK szw_args)
+ argcheck = unitOL (ARGCHECK szw_args)
in
schemeE szw_args 0 p_init body `thenBc` \ body_code ->
- emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
+ emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code)
+ (Right original_body))
+
+ where
+ maybe_toplevel_null_con_rhs
+ | is_top && null args
+ = case snd body of
+ AnnVar v_wrk
+ -> case isDataConId_maybe v_wrk of
+ Nothing -> Nothing
+ Just dc_wrk | nm == dataConWrapId dc_wrk
+ -> Just dc_wrk
+ | otherwise
+ -> Nothing
+ other -> Nothing
+ | otherwise
+ = Nothing
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'. Return the values which the stack environment
-- ToDo: don't build thunks for things with no free variables
buildThunk dd ([], size, id, off)
- = PUSH_G (getName id)
+ = PUSH_G (Left (getName id))
`consOL` unitOL (MKAP (off+size-1) size)
buildThunk dd ((fv:fvs), size, id, off)
= case pushAtom True dd p' (AnnVar fv) of
allocCode = toOL (map ALLOC sizes)
in
schemeE d' s p' b `thenBc` \ bodyCode ->
- mapBc schemeR (zip xs rhss) `thenBc_`
+ mapBc (schemeR False) (zip xs rhss) `thenBc_`
returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
scrut_primrep = typePrimRep (idType bndr)
isAlgCase
= case scrut_primrep of
- CharRep -> False ; AddrRep -> False
+ CharRep -> False ; AddrRep -> False ; WordRep -> False
IntRep -> False ; FloatRep -> False ; DoubleRep -> False
+ VoidRep -> False ;
PtrRep -> True
other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
-- given an alt, return a discr and code for it.
codeAlt alt@(discr, binds_f, rhs)
| isAlgCase
- = let -- The constr args in r->l order
- binds_r = reverse binds_f
- -- r->l order, but nptrs first, then ptrs
- -- this is the reverse order of the heap representation
- binds_r_split = filter (not.isPtr) binds_r ++ filter isPtr binds_r
- isPtr = isFollowableRep . typePrimRep . idType
-
- binds_r_tszsw = map taggedIdSizeW binds_r_split
- binds_tszw = sum binds_r_tszsw
- p'' = addListToFM
- p' (zip (reverse binds_r_split) (mkStackOffsets d' (reverse binds_r_tszsw)))
- d'' = d' + binds_tszw
- unpack_code = mkUnpackCode (map (typePrimRep.idType)
- (reverse binds_r_split))
- in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
- returnBc (my_discr alt, unpack_code `appOL` rhs_code)
+ = let (unpack_code, d_after_unpack, p_after_unpack)
+ = mkUnpackCode binds_f d' p'
+ in schemeE d_after_unpack s p_after_unpack rhs
+ `thenBc` \ rhs_code ->
+ returnBc (my_discr alt, unpack_code `appOL` rhs_code)
| otherwise
= ASSERT(null binds_f)
schemeE d' s p' rhs `thenBc` \ rhs_code ->
returnBc (my_discr alt, rhs_code)
- my_discr (DEFAULT, binds, rhs) = NoDiscr
- my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
+ my_discr (DEFAULT, binds, rhs) = NoDiscr
+ my_discr (DataAlt dc, binds, rhs)
+ | isUnboxedTupleCon dc
+ = unboxedTupleException
+ | otherwise
+ = DiscrP (dataConTag dc - fIRST_TAG)
my_discr (LitAlt l, binds, rhs)
= case l of MachInt i -> DiscrI (fromInteger i)
MachFloat r -> DiscrF (fromRational r)
MachDouble r -> DiscrD (fromRational r)
+ MachChar i -> DiscrI i
+ _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
maybe_ncons
| not isAlgCase = Nothing
(pprCoreExpr (deAnnotate other))
--- Compile code to do a tail call. If the function eventually
--- to be called is a constructor, split the args into ptrs and
--- non-ptrs, and push the nonptrs, then the ptrs, and then do PACK.
--- *** This assumes that the root expression passed in represents
--- a saturated constructor call. ***
+-- Compile code to do a tail call. Three cases:
+--
+-- 1. A nullary constructor. Push its closure on the stack
+-- and SLIDE and RETURN.
--
--- Otherwise, just push the args right-to-left, SLIDE and ENTER.
+-- 2. Application of a non-nullary constructor, by defn saturated.
+-- Split the args into ptrs and non-ptrs, and push the nonptrs,
+-- then the ptrs, and then do PACK and RETURN.
+--
+-- 3. Otherwise, it must be a function call. Push the args
+-- right to left, SLIDE and ENTER.
schemeT :: Int -- Stack depth
-> Sequel -- Sequel depth
-> BCInstrList
schemeT d s p app
- = code
+-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
+-- = panic "schemeT ?!?!"
+
+ -- Handle case 1
+ | is_con_call && null args_r_to_l
+ = (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
+
where
-- 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)
- other -> pprPanic "schemeT"
- (ppr (deAnnotate (panic "schemeT.chomp", other)))
+ 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
isTypeAtom (AnnType _) = True
-- args appropriately.
maybe_dcon = isDataConId_maybe fn
is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
+ (Just con) = maybe_dcon
args_final_r_to_l
| not is_con_call
atomRep (AnnLit l) = literalPrimRep l
atomRep (AnnNote n b) = atomRep (snd b)
atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
+atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
+
-- 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
-- along the constructor and the stack.
---
--- The supplied PrimReps are in heap rep order, that is,
--- left to right, but with all the ptrs first, then the nonptrs.
-mkUnpackCode :: [PrimRep] -> BCInstrList
-mkUnpackCode reps
- = all_code
+--
+-- Supposing a constructor in the heap has layout
+--
+-- Itbl p_1 ... p_i np_1 ... np_j
+--
+-- then we add to the stack, shown growing down, the following:
+--
+-- (previous stack)
+-- p_i
+-- ...
+-- p_1
+-- np_j
+-- tag_for(np_j)
+-- ..
+-- np_1
+-- tag_for(np_1)
+--
+-- so that in the common case (ptrs only) a single UNPACK instr can
+-- copy all the payload of the constr onto the stack with no further ado.
+
+mkUnpackCode :: [Id] -- constr args
+ -> Int -- depth before unpack
+ -> BCEnv -- env before unpack
+ -> (BCInstrList, Int, BCEnv)
+mkUnpackCode vars d p
+ = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
+ -- ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
+ -- ++ "\n") (
+ (code_p `appOL` code_np, d', p')
+ --)
where
- all_code = ptrs_code `appOL` do_nptrs ptrs_szw ptrs_szw reps_nptr
-
- (reps_ptr, reps_nptr) = span isFollowableRep reps
-
- ptrs_szw = sum (map untaggedSizeW reps_ptr)
- ptrs_code | null reps_ptr = nilOL
- | otherwise = unitOL (UNPACK ptrs_szw)
-
+ -- vars with reps
+ vreps = [(var, typePrimRep (idType var)) | var <- vars]
+
+ -- ptrs and nonptrs, forward
+ vreps_p = filter (isFollowableRep.snd) vreps
+ vreps_np = filter (not.isFollowableRep.snd) vreps
+
+ -- the order in which we will augment the environment
+ vreps_env = reverse vreps_p ++ reverse vreps_np
+
+ -- new env and depth
+ vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
+ p' = addListToFM p (zip (map fst vreps_env)
+ (mkStackOffsets d vreps_env_tszsw))
+ d' = d + sum vreps_env_tszsw
+
+ -- code to unpack the ptrs
+ ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
+ code_p | null vreps_p = nilOL
+ | otherwise = unitOL (UNPACK ptrs_szw)
+
+ -- code to unpack the nonptrs
+ vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
+ code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
do_nptrs off_h off_s [] = nilOL
do_nptrs off_h off_s (npr:nprs)
= case npr of
IntRep -> approved ; FloatRep -> approved
DoubleRep -> approved ; AddrRep -> approved
+ CharRep -> approved
_ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
where
- approved = UPK_TAG usizeW off_h off_s `consOL` theRest
- theRest = do_nptrs (off_h + usizeW) (off_s + tsizeW) nprs
+ approved = UPK_TAG usizeW (off_h-usizeW) off_s `consOL` theRest
+ theRest = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
usizeW = untaggedSizeW npr
tsizeW = taggedSizeW npr
-- 6 stack has valid words 0 .. 5.
pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
-pushAtom tagged d p (AnnVar v)
+pushAtom tagged d p (AnnVar v)
+
+ | idPrimRep v == VoidRep
+ = ASSERT(tagged)
+ (unitOL (PUSH_TAG 0), 1)
+
+ | Just primop <- isPrimOpId_maybe v
+ = case primop of
+ CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls"
+ other -> (unitOL (PUSH_G (Right primop)), 1)
+
+ | otherwise
= let str = "\npushAtom " ++ showSDocDebug (ppr v)
++ " :: " ++ showSDocDebug (pprType (idType v))
++ ", depth = " ++ show d
++ ", tagged = " ++ show tagged ++ ", env =\n" ++
- showSDocDebug (nest 4 (vcat (map ppr (fmToList p))))
+ showSDocDebug (ppBCEnv p)
++ " --> words: " ++ show (snd result) ++ "\n" ++
showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
++ "\nendPushAtom " ++ showSDocDebug (ppr v)
+ where
+ cmp_snd x y = compare (snd x) (snd y)
str' = if str == str then str else str
result
= case lookupBCEnv_maybe p v of
Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
- Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), nwords)
+ Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
nm = case isDataConId_maybe v of
Just c -> getName c
sz_u = untaggedIdSizeW v
nwords = if tagged then sz_t else sz_u
in
- trace str'
+ --trace str'
result
pushAtom True d p (AnnLit lit)
pushAtom False d p (AnnLit lit)
= case lit of
+ MachWord w -> code WordRep
MachInt i -> code IntRep
MachFloat r -> code FloatRep
MachDouble r -> code DoubleRep
let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+
in unsafePerformIO (
- do a@(Ptr addr) <- mallocBytes (n+1)
- strncpy a ba (fromIntegral n)
- writeCharOffAddr addr n '\0'
- return addr
+ do (Ptr a#) <- mallocBytes (n+1)
+ strncpy (Ptr a#) ba (fromIntegral n)
+ writeCharOffAddr (A# a#) n '\0'
+ return (A# a#)
)
_ -> panic "StgInterp.lit2expr: unhandled string constant type"
pushAtom tagged d p (AnnNote note e)
= pushAtom tagged d p (snd e)
+pushAtom tagged d p (AnnLam x e)
+ | isTyVar x
+ = pushAtom tagged d p (snd e)
+
pushAtom tagged d p other
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, other)))
taggedIdSizeW = taggedSizeW . typePrimRep . idType
untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
+unboxedTupleException :: a
+unboxedTupleException
+ = throwDyn (Panic "bytecode generator can't handle unboxed tuples")
+
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff