import Id
import FiniteMap
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
+import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses )
import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
import PrimRep
import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
-import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe,
- isTyVarTy )
+import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- dataConWrapId, isUnboxedTupleCon )
+ isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
+ dataConRepArity )
import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
- isFunTyCon, isUnboxedTupleTyCon )
+ isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
-import Type ( Type, repType, splitFunTys, dropForAlls )
+import Type ( Type, repType, splitFunTys, dropForAlls, pprType )
import Util
import DataCon ( dataConRepArity )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
-import TysPrim ( foreignObjPrimTyCon,
- arrayPrimTyCon, mutableArrayPrimTyCon,
+import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon
)
import PrimRep ( isFollowableRep )
import Unique ( mkPseudoUnique3 )
import FastString ( FastString(..), unpackFS )
import Panic ( GhcException(..) )
-import PprType ( pprType )
-import SMRep ( arrWordsHdrSize, arrPtrsHdrSize )
+import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord )
+import Bitmap ( intsToReverseBitmap, mkBitmap )
import OrdList
import Constants ( wORD_SIZE )
import GHC.Exts ( Int(..), ByteArray# )
-import Control.Monad ( when, mapAndUnzipM )
-import Data.Char ( ord )
-import Data.Bits
+import Control.Monad ( when )
+import Data.Char ( ord, chr )
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
byteCodeGen :: DynFlags
- -> ModGuts
+ -> [CoreBind]
+ -> TypeEnv
-> IO CompiledByteCode
-byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env })
+byteCodeGen dflags binds type_env
= do showPass dflags "ByteCodeGen"
let local_tycons = typeEnvTyCons type_env
local_classes = typeEnvClasses type_env
tycs = local_tycons ++ map classTyCon local_classes
- let flatBinds = concatMap getBind binds
- getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
- getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
+ let flatBinds = [ (bndr, freeVars rhs)
+ | (bndr, rhs) <- flattenBinds binds]
(BcM_State final_ctr mallocd, proto_bcos)
- <- runBc (BcM_State 0 []) (mapM (schemeR True []) flatBinds)
- -- ^^
- -- better be no free vars in these top-level bindings
+ <- runBc (mapM schemeTopBind flatBinds)
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
- let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel")
- invented_id = mkLocalId invented_name (panic "invented_id's type")
- annexpr = freeVars expr
- fvs = filter (not.isTyVar) (varSetElems (fst annexpr))
-
+ let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel")
+ invented_id = mkLocalId invented_name (panic "invented_id's type")
+
(BcM_State final_ctr mallocd, proto_bco)
- <- runBc (BcM_State 0 [])
- (schemeR True fvs (invented_id, annexpr))
+ <- runBc (schemeTopBind (invented_id, freeVars expr))
when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
-> Int
-> Int
-> [StgWord]
+ -> Bool -- True <=> is a return point, rather than a function
-> [Ptr ()]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
+ is_ret mallocd_blocks
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
+ | is_ret = peep_d
+ -- don't do stack checks at return points;
+ -- everything is aggregated up to the top BCO
+ -- (which must be a function)
| 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
+ = 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)
| isFollowableRep rep = False : argBits args
| otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
-mkBitmap :: [Bool] -> [StgWord]
-mkBitmap [] = []
-mkBitmap stuff = chunkToLiveness chunk : mkBitmap rest
- where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
-
-chunkToLiveness :: [Bool] -> StgWord
-chunkToLiveness chunk =
- foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
-
--- make a bitmap where the slots specified are the *zeros* in the bitmap.
--- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero,
--- just to make the bitmap easier to read).
-intsToBitmap :: Int -> [Int] -> [StgWord]
-intsToBitmap size slots{- must be sorted -}
- | size <= 0 = []
- | otherwise =
- (foldr xor init (map (1 `shiftL`) these)) :
- intsToBitmap (size - wORD_SIZE_IN_BITS)
- (map (\x -> x - wORD_SIZE_IN_BITS) rest)
- where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
- init
- | size >= wORD_SIZE_IN_BITS = complement 0
- | otherwise = (1 `shiftL` size) - 1
-
-wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int
+-- -----------------------------------------------------------------------------
+-- schemeTopBind
+
+-- Compile code for the right-hand side of a top-level binding
+
+schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
+
+
+schemeTopBind (id, rhs)
+ | Just data_con <- isDataConWorkId_maybe id,
+ isNullaryDataCon data_con
+ = -- Special case for the worker of a nullary data con.
+ -- It'll look like this: Nil = /\a -> Nil a
+ -- If we feed it into schemeR, we'll get
+ -- Nil = Nil
+ -- because mkConAppCode treats nullary constructor applications
+ -- by just re-using the single top-level definition. So
+ -- for the worker itself, we must allocate it directly.
+ emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+
+ | otherwise
+ = schemeR [{- No free variables -}] (id, rhs)
-- -----------------------------------------------------------------------------
-- schemeR
--- Compile code for the right hand side of a let binding.
+-- Compile code for a right-hand side, to give a BCO that,
+-- when executed with the free variables and arguments on top of the stack,
+-- will return with a pointer to the result on top of the stack, after
+-- removing the free variables and arguments.
+--
-- 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. Bool indicates top-levelness.
-
-schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
-schemeR is_top fvs (nm, rhs)
+-- resulting BCO a name.
+
+schemeR :: [Id] -- Free vars of the RHS, ordered as they
+ -- will appear in the thunk. Empty for
+ -- top-level things, which have no free vars.
+ -> (Id, AnnExpr Id VarSet)
+ -> BcM (ProtoBCO Name)
+schemeR fvs (nm, rhs)
{-
| trace (showSDoc (
(char ' '
$$ char ' '
))) False
= undefined
--}
| otherwise
- = schemeR_wrk is_top fvs rhs nm (collect [] rhs)
-
-
-collect xs (_, AnnNote note e)
- = collect xs e
-collect xs (_, AnnLam x e)
- = collect (if isTyVar x then xs else (x:xs)) e
-collect xs not_lambda
- = (reverse xs, not_lambda)
+-}
+ = schemeR_wrk fvs nm rhs (collect [] rhs)
-schemeR_wrk is_top fvs original_body nm (args, body)
- | Just dcon <- maybe_toplevel_null_con_rhs
- = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) $
- ASSERT(null fvs)
- emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
- (Right original_body) 0 0 [{-no bitmap-}])
+collect xs (_, AnnNote note e) = collect xs e
+collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e
+collect xs (_, not_lambda) = (reverse xs, not_lambda)
- | otherwise
+schemeR_wrk fvs nm original_body (args, body)
= let
all_args = reverse args ++ fvs
arity = length all_args
- -- these are the args in reverse order. We're compiling a function
+ -- all_args are the args in reverse order. We're compiling a function
-- \fv1..fvn x1..xn -> e
-- i.e. the fvs come first
in
schemeE szw_args 0 p_init body `thenBc` \ body_code ->
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
- arity bitmap_size bitmap)
-
- where
- maybe_toplevel_null_con_rhs
- | is_top && null args
- = case nukeTyArgs (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
+ arity bitmap_size bitmap False{-not alts-})
- nukeTyArgs (AnnApp f (_, AnnType _)) = nukeTyArgs (snd f)
- nukeTyArgs other = other
+fvsToEnv :: BCEnv -> VarSet -> [Id]
+-- Takes the free variables of a right-hand side, and
+-- delivers an ordered list of the local variables that will
+-- be captured in the thunk for the RHS
+-- The BCEnv argument tells which variables are in the local
+-- environment: these are the ones that should be captured
+--
+-- The code that constructs the thunk, and the code that executes
+-- it, have to agree about this layout
+fvsToEnv p fvs = [v | v <- varSetElems fvs,
+ isId v, -- Could be a type variable
+ v `elemFM` p]
-- -----------------------------------------------------------------------------
-- schemeE
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
-schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
+schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
-- Delegate tail-calls to schemeT.
-schemeE d s p e@(fvs, AnnApp f a)
- = schemeT d s p (fvs, AnnApp f a)
+schemeE d s p e@(AnnApp f a)
+ = schemeT d s p e
-schemeE d s p e@(fvs, AnnVar v)
+schemeE d s p e@(AnnVar v)
| not (isUnLiftedType v_type)
= -- Lifted-type thing; push it in the normal way
- schemeT d s p (fvs, AnnVar v)
+ schemeT d s p e
| otherwise
= -- Returning an unlifted value.
v_type = idType v
v_rep = typePrimRep v_type
-schemeE d s p (fvs, AnnLit literal)
+schemeE d s p (AnnLit literal)
= pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) ->
let l_rep = literalPrimRep literal
in returnBc (push -- value onto stack
`snocOL` RETURN_UBX l_rep) -- go
-#if 0
-{-
- Disabled for now --SDM (TODO: reinstate later, but do it better)
-
- Deal specially with the cases
- let x = fn atom1 .. atomn in B
- and
- let x = Con atom1 .. atomn in B
- (Con must be saturated)
-
- In these cases, generate code to allocate in-line.
-
- This is optimisation of the general case for let, which follows
- this one; this case can safely be omitted. The reduction in
- interpreter execution time seems to be around 5% for some programs,
- with a similar drop in allocations.
-
- This optimisation should be done more cleanly. As-is, it is
- inapplicable to RHSs in letrecs, and needlessly duplicates code in
- schemeR and schemeT. Some refactoring of the machinery would cure
- both ills.
--}
-schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b)
- | ok_to_go
- = let d_init = if is_con then d else d'
- in
- mkPushes d_init args_r_to_l_reordered `thenBc` \ (d_final, push_code) ->
- schemeE d' s p' b `thenBc` \ body_code ->
- let size = d_final - d_init
- alloc = if is_con then nilOL else unitOL (ALLOC size)
- pack = unitOL (if is_con then PACK the_dcon size else MKAP size size)
- in
- returnBc (alloc `appOL` push_code `appOL` pack
- `appOL` body_code)
- where
- -- Decide whether we can do this or not
- (ok_to_go, is_con, the_dcon, the_fn)
- = case maybe_fn of
- Nothing -> (False, bomb 1, bomb 2, bomb 3)
- Just (Left fn) -> (True, False, bomb 5, fn)
- Just (Right dcon)
- | dataConRepArity dcon <= length args_r_to_l
- -> (True, True, dcon, bomb 6)
- | otherwise
- -> (False, bomb 7, bomb 8, bomb 9)
- bomb n = panic ("schemeE.is_con(hacky hack hack) " ++ show n)
-
- -- Extract the args (R -> L) and fn
- args_r_to_l_reordered
- | not is_con
- = args_r_to_l
- | otherwise
- = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
- where isPtr = isFollowableRep . atomRep
-
- args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
- isTypeAtom (AnnType _) = True
- isTypeAtom _ = False
-
- (args_r_to_l_raw, maybe_fn) = chomp rhs
- chomp expr
- = case snd expr of
- AnnVar v
- | isFCallId v || isPrimOpId v
- -> ([], Nothing)
- | otherwise
- -> case isDataConId_maybe v of
- Just dcon -> ([], Just (Right dcon))
- Nothing -> ([], Just (Left v))
- AnnApp f a -> case chomp f of (az, f) -> (a:az, f)
- AnnNote n e -> chomp e
- other -> ([], Nothing)
-
- -- This is the env in which to translate the body
- p' = addToFM p x d
- d' = d + 1
-
- -- Shove the args on the stack, including the fn in the non-dcon case
- tag_when_push = not is_con
-
-#endif
+schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
+ | (AnnVar v, args_r_to_l) <- splitApp rhs,
+ Just data_con <- isDataConWorkId_maybe v,
+ dataConRepArity data_con == length args_r_to_l
+ = -- Special case for a non-recursive let whose RHS is a
+ -- saturatred constructor application.
+ -- Just allocate the constructor and carry on
+ mkConAppCode d s p data_con args_r_to_l `thenBc` \ alloc_code ->
+ schemeE (d+1) s (addToFM p x d) body `thenBc` \ body_code ->
+ returnBc (alloc_code `appOL` body_code)
-- General case for let. Generates correct, if inefficient, code in
-- all situations.
-schemeE d s p (fvs, AnnLet binds b)
+schemeE d s p (AnnLet binds (_,body))
= let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
n_binds = length xs
- is_local id = not (isTyVar id) && elemFM id p'
- fvss = map (filter is_local . varSetElems . fst) rhss
+ fvss = map (fvsToEnv p' . fst) rhss
- -- Sizes of free vars, + 1 for the fn
- sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss
+ -- Sizes of free vars
+ sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss
-- the arity of each rhs
arities = map (length . fst . collect []) rhss
-- ToDo: don't build thunks for things with no free variables
build_thunk dd [] size bco off
= returnBc (PUSH_BCO bco
- `consOL` unitOL (MKAP (off+size-1) size))
+ `consOL` unitOL (MKAP (off+size) size))
build_thunk dd (fv:fvs) size bco off = do
(push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off
mkAlloc sz arity = ALLOC_PAP arity sz
compile_bind d' fvs x rhs size off = do
- bco <- schemeR False fvs (x,rhs)
+ bco <- schemeR fvs (x,rhs)
build_thunk d' fvs size bco off
compile_binds =
zip5 fvss xs rhss sizes [n_binds, n_binds-1 .. 1]
]
in do
- body_code <- schemeE d' s p' b
+ body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
-schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
+schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
-- Convert
-- case .... of x { (# VoidRep'd-thing, a #) -> ... }
= --trace "automagic mashing of case alts (# a, VoidRep #)" $
doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
-schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
+schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
-- Similarly, convert
-- case .... of x { (# a #) -> ... }
= --trace "automagic mashing of case alts (# a #)" $
doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
-schemeE d s p (fvs, AnnCase scrut bndr alts)
+schemeE d s p (AnnCase scrut bndr alts)
= doCase d s p scrut bndr alts False{-not an unboxed tuple-}
-schemeE d s p (fvs, AnnNote note body)
+schemeE d s p (AnnNote note (_, body))
= schemeE d s p body
schemeE d s p other
= pprPanic "ByteCodeGen.schemeE: unhandled case"
- (pprCoreExpr (deAnnotate other))
+ (pprCoreExpr (deAnnotate' other))
-- Compile code to do a tail call. Specifically, push the fn,
-- 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.
+-- 1. The fn denotes a ccall. Defer to generateCCall.
--
-- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat
-- it simply as b -- since the representations are identical
-- (the VoidRep takes up zero stack space). Also, spot
-- (# b #) and treat it as b.
--
--- 3. The fn denotes a ccall. Defer to generateCCall.
---
--- 4. Application of a non-nullary constructor, by defn saturated.
+-- 3. Application of a 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.
--
--- 5. Otherwise, it must be a function call. Push the args
+-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Int -- Stack depth
-> Sequel -- Sequel depth
-> BCEnv -- stack env
- -> AnnExpr Id VarSet
+ -> AnnExpr' Id VarSet
-> BcM BCInstrList
schemeT d s p app
-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
-- = panic "schemeT ?!?!"
--- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
+-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
-- = error "?!?!"
-- Case 0
`snocOL` ENTER)
-- Case 1
- | Just con <- maybe_dcon, null args_r_to_l
- = returnBc (
- (PUSH_G (getName con) `consOL` mkSLIDE 1 (d-s))
- `snocOL` ENTER
- )
-
- -- Case 3
| Just (CCall ccall_spec) <- isFCallId_maybe fn
= generateCCall d s p ccall_spec fn args_r_to_l
- -- Case 4: Constructor application
- | Just con <- maybe_dcon
- = if isUnboxedTupleCon con
- then case args_r_to_l of
- [arg1,arg2] | isVoidRepAtom arg1 ->
- unboxedTupleReturn d s p arg2
- [arg1,arg2] | isVoidRepAtom arg2 ->
- unboxedTupleReturn d s p arg1
- _other -> unboxedTupleException
- else doConstructorApp d s p con args_r_to_l
-
- -- Case 5: Tail call of function
+ -- Case 2: Constructor application
+ | Just con <- maybe_saturated_dcon,
+ isUnboxedTupleCon con
+ = case args_r_to_l of
+ [arg1,arg2] | isVoidRepAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVoidRepAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> unboxedTupleException
+
+ -- Case 3: Ordinary data constructor
+ | Just con <- maybe_saturated_dcon
+ = mkConAppCode d s p con args_r_to_l `thenBc` \ alloc_con ->
+ returnBc (alloc_con `appOL`
+ mkSLIDE 1 (d - s) `snocOL`
+ ENTER)
+
+ -- Case 4: Tail call of function
| otherwise
= doTailCall d s p fn args_r_to_l
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call
= let extract_constr_Names ty
- = case splitTyConApp_maybe (repType ty) of
- (Just (tyc, [])) | isDataTyCon tyc
- -> map getName (tyConDataCons tyc)
- other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
- in
+ | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
+ isDataTyCon tyc
+ = map (getName . dataConWorkId) (tyConDataCons tyc)
+ -- NOTE: use the worker name, not the source name of
+ -- the DataCon. See DataCon.lhs for details.
+ | otherwise
+ = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+ in
case app of
- (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
+ (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
-> case isPrimOpId_maybe v of
Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
other -> Nothing
other -> Nothing
- -- Extract the args (R->L) and fn
- (args_r_to_l, fn) = chomp app
- chomp expr
- = case snd expr of
- AnnVar v -> ([], v)
- AnnApp f (_,a)
- | isTypeAtom a -> chomp f
- | otherwise -> case chomp f of (az, f) -> (a:az, f)
- AnnNote n e -> chomp e
- other -> pprPanic "schemeT"
- (ppr (deAnnotate (panic "schemeT.chomp", other)))
+ -- Extract the args (R->L) and fn
+ -- The function will necessarily be a variable,
+ -- because we are compiling a tail call
+ (AnnVar fn, args_r_to_l) = splitApp app
- n_args = length args_r_to_l
-
- -- only consider this to be a constructor application iff it is
+ -- Only consider this to be a constructor application iff it is
-- saturated. Otherwise, we'll call the constructor wrapper.
- maybe_dcon = case isDataConId_maybe fn of
- Just con | dataConRepArity con == n_args -> Just con
- _ -> Nothing
+ n_args = length args_r_to_l
+ maybe_saturated_dcon
+ = case isDataConWorkId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
-- -----------------------------------------------------------------------------
--- Generate code to build a constructor application and enter/return it.
-
-doConstructorApp
- :: Int -> Sequel -> BCEnv
- -> DataCon -> [AnnExpr' Id VarSet] -- args, in *reverse* order
- -> BcM BCInstrList
-doConstructorApp d s p con args = do_pushery d con_args
+-- Generate code to build a constructor application,
+-- leaving it on top of the stack
+
+mkConAppCode :: Int -> Sequel -> BCEnv
+ -> DataCon -- The data constructor
+ -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
+ -> BcM BCInstrList
+
+mkConAppCode orig_d s p con [] -- Nullary constructor
+ = ASSERT( isNullaryDataCon con )
+ returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
+ -- Instead of doing a PACK, which would allocate a fresh
+ -- copy of this constructor, use the single shared version.
+
+mkConAppCode orig_d s p con args_r_to_l
+ = ASSERT( dataConRepArity con == length args_r_to_l )
+ do_pushery orig_d (non_ptr_args ++ ptr_args)
where
-- The args are already in reverse order, which is the way PACK
-- expects them to be. We must push the non-ptrs after the ptrs.
- con_args = nptrs ++ ptrs
- where (ptrs, nptrs) = partition isPtr args
- isPtr = isFollowableRep . atomRep
-
- narg_words = sum (map (getPrimRepSize.atomRep) con_args)
+ (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
do_pushery d (arg:args)
= pushAtom d p arg `thenBc` \ (push, arg_words) ->
do_pushery (d+arg_words) args `thenBc` \ more_push_code ->
returnBc (push `appOL` more_push_code)
do_pushery d []
- = returnBc ( (PACK con narg_words `consOL`
- mkSLIDE 1 (d - narg_words - s)) `snocOL`
- ENTER
- )
+ = returnBc (unitOL (PACK con n_arg_words))
+ where
+ n_arg_words = d - orig_d
+
-- -----------------------------------------------------------------------------
-- Returning an unboxed tuple with one non-void component (the only
-> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
-> Bool -- True <=> is an unboxed tuple case, don't enter the result
-> BcM BCInstrList
-doCase d s p scrut bndr alts is_unboxed_tuple
+doCase d s p (_,scrut)
+ bndr alts is_unboxed_tuple
= let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
-- given an alt, return a discr and code for it.
- codeALt alt@(DEFAULT, _, rhs)
+ codeALt alt@(DEFAULT, _, (_,rhs))
= schemeE d_alts s p_alts rhs `thenBc` \ rhs_code ->
returnBc (NoDiscr, rhs_code)
- codeAlt alt@(discr, bndrs, rhs)
+ codeAlt alt@(discr, bndrs, (_,rhs))
-- primitive or nullary constructor alt: no need to UNPACK
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
= case l of MachInt i -> DiscrI (fromInteger i)
MachFloat r -> DiscrF (fromRational r)
MachDouble r -> DiscrD (fromRational r)
- MachChar i -> DiscrI i
+ MachChar i -> DiscrI (ord i)
_ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
maybe_ncons
-- things that are pointers, whereas in CgBindery the code builds the
-- bitmap from the free slots and unboxed bindings.
-- (ToDo: merge?)
- bitmap = intsToBitmap d{-size-} (sortLt (<) rel_slots)
+ bitmap = intsToReverseBitmap d{-size-} (sortLt (<) rel_slots)
where
binds = fmToList p
rel_slots = concat (map spread binds)
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
- 0{-no arity-} d{-bitmap size-} bitmap
+ 0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
-- in
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
-- "\n bitmap = " ++ show bitmap) $ do
-- Deal with a CCall.
-- Taggedly push the args onto the stack R->L,
--- deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
--- payloads in Ptr/Byte arrays). Then, generate the marshalling
+-- deferencing ForeignObj#s and adjusting addrs to point to
+-- payloads in Ptr/Byte arrays. Then, generate the marshalling
-- (machine) code for the ccall, and create bytecodes to call that and
-- then return in the right way.
depth, and we RETURN.
This arrangement makes it simple to do f-i-dynamic since the Addr#
- value is the first arg anyway. It also has the virtue that the
- stack is GC-understandable at all times.
+ value is the first arg anyway.
The marshalling code is generated specifically for this
call site, and so knows exactly the (Haskell) stack
StaticTarget target
-> ioToBc (lookupStaticPtr target) `thenBc` \res ->
returnBc (True, res)
- CasmTarget _
- -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
in
get_target_info `thenBc` \ (is_static, static_target_addr) ->
let
recordMallocBc addr_of_marshaller `thenBc_`
let
-- Offset of the next stack frame down the stack. The CCALL
- -- instruction will temporarily shift the stack pointer up by
- -- this much during the call, and shift it down again afterwards.
- -- This is so that we don't have to worry about constructing
- -- a bitmap to describe the stack layout of the call: the
- -- contents of this part of the stack are irrelevant anyway,
- -- it is only used to communicate the arguments to the
- -- marshalling code.
+ -- instruction needs to describe the chunk of stack containing
+ -- the ccall args to the GC, so it needs to know how large it
+ -- is. See comment in Interpreter.c with the CCALL instruction.
stk_offset = d_after_r - s
-- do the call
mkDummyLiteral :: PrimRep -> Literal
mkDummyLiteral pr
= case pr of
- CharRep -> MachChar 0
+ CharRep -> MachChar (chr 0)
IntRep -> MachInt 0
WordRep -> MachWord 0
DoubleRep -> MachDouble 0
| Just primop <- isPrimOpId_maybe v
= returnBc (unitOL (PUSH_PRIMOP primop), 1)
- | otherwise
- = let
+ | Just d_v <- lookupBCEnv_maybe p v -- v is a local variable
+ = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
-- d - d_v the number of words between the TOS
-- and the 1st slot of the object
--
--
-- Having found the last slot, we proceed to copy the right number of
-- slots on to the top of the stack.
- --
- result
- = case lookupBCEnv_maybe p v of
- Just d_v -> (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
- Nothing -> ASSERT(sz == 1) (unitOL (PUSH_G nm), sz)
- nm = case isDataConId_maybe v of
- Just c -> getName c
- Nothing -> getName v
+ | otherwise -- v must be a global variable
+ = ASSERT(sz == 1)
+ returnBc (unitOL (PUSH_G (getName v)), sz)
- sz = idSizeW v
- in
- returnBc result
+ where
+ sz = idSizeW v
pushAtom d p (AnnLit lit)
= case lit of
- MachLabel fs -> code CodePtrRep
- MachWord w -> code WordRep
- MachInt i -> code IntRep
- MachFloat r -> code FloatRep
- MachDouble r -> code DoubleRep
- MachChar c -> code CharRep
- MachStr s -> pushStr s
+ MachLabel fs _ -> code CodePtrRep
+ MachWord w -> code WordRep
+ MachInt i -> code IntRep
+ MachFloat r -> code FloatRep
+ MachDouble r -> code DoubleRep
+ MachChar c -> code CharRep
+ MachStr s -> pushStr s
where
code rep
= let size_host_words = getPrimRepSize rep
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
bind x f = f x
+splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann])
+ -- The arguments are returned in *right-to-left* order
+splitApp (AnnApp (_,f) (_,a))
+ | isTypeAtom a = splitApp f
+ | otherwise = case splitApp f of
+ (f', as) -> (f', a:as)
+splitApp (AnnNote n (_,e)) = splitApp e
+splitApp e = (e, [])
+
+
isTypeAtom :: AnnExpr' id ann -> Bool
isTypeAtom (AnnType _) = True
isTypeAtom _ = False
atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
+isPtrAtom :: AnnExpr' Id ann -> Bool
+isPtrAtom e = isFollowableRep (atomRep e)
+
-- 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
-- should map these items to.
x <- io
return (st, x)
-runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
-runBc st0 (BcM m) = do
- (st1, res) <- m st0
- return (st1, res)
+runBc :: BcM r -> IO (BcM_State, r)
+runBc (BcM m) = m (BcM_State 0 [])
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
projects / ghc-hetmet.git / blobdiff