%
-% (c) The University of Glasgow 2002
+% (c) The University of Glasgow 2002-2006
%
-\section[ByteCodeGen]{Generate bytecode from Core}
+
+ByteCodeGen: Generate bytecode from Core
\begin{code}
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
import ByteCodeInstr
-import ByteCodeFFI ( mkMarshalCode, moan64 )
-import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO,
- assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
-import ByteCodeLink ( lookupStaticPtr )
+import ByteCodeItbls
+import ByteCodeFFI
+import ByteCodeAsm
+import ByteCodeLink
import Outputable
-import Name ( Name, getName, mkSystemVarName )
+import Name
import Id
import FiniteMap
-import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses )
-import CoreUtils ( exprType )
+import ForeignCall
+import HscTypes
+import CoreUtils
import CoreSyn
-import PprCore ( pprCoreExpr )
-import Literal ( Literal(..), literalType )
-import PrimOp ( PrimOp(..) )
-import CoreFVs ( freeVars )
-import Type ( isUnLiftedType, splitTyConApp_maybe )
-import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
- dataConRepArity )
-import TyCon ( TyCon, tyConFamilySize, isDataTyCon,
- tyConDataCons, isUnboxedTupleTyCon )
-import Class ( Class, classTyCon )
-import Type ( Type, repType, splitFunTys, dropForAlls, pprType )
+import PprCore
+import Literal
+import PrimOp
+import CoreFVs
+import Type
+import DataCon
+import TyCon
+import Class
+import Type
import Util
-import DataCon ( dataConRepArity )
-import Var ( isTyVar )
-import VarSet ( VarSet, varSetElems )
-import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon,
- byteArrayPrimTyCon, mutableByteArrayPrimTyCon
- )
-import DynFlags ( DynFlags, DynFlag(..) )
-import ErrUtils ( showPass, dumpIfSet_dyn )
-import Unique ( mkPseudoUniqueE )
-import FastString ( FastString(..), unpackFS )
-import Panic ( GhcException(..) )
-import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord,
- CgRep(..), cgRepSizeW, isFollowableArg, idCgRep )
-import Bitmap ( intsToReverseBitmap, mkBitmap )
+import DataCon
+import Var
+import VarSet
+import TysPrim
+import DynFlags
+import ErrUtils
+import Unique
+import FastString
+import Panic
+import SMRep
+import Bitmap
import OrdList
-import Constants ( wORD_SIZE )
+import Constants
import Data.List ( intersperse, sortBy, zip4, zip6, partition )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
- withForeignPtr )
+ withForeignPtr, castFunPtrToPtr )
import Foreign.C ( CInt )
import Control.Exception ( throwDyn )
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
- invented_id = mkLocalId invented_name (panic "invented_id's type")
+ invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
(BcM_State final_ctr mallocd, proto_bco)
<- runBc (schemeTopBind (invented_id, freeVars expr))
-> Int
-> [StgWord]
-> Bool -- True <=> is a return point, rather than a function
- -> [Ptr ()]
+ -> [BcPtr]
-> ProtoBCO name
mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
is_ret mallocd_blocks
-- 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
| otherwise
= peep_d -- the supposedly common case
+ -- We assume that this sum doesn't wrap
stack_overest = sum (map bciStackUse peep_d)
-- Merge local pushes
= schemeR_wrk fvs nm rhs (collect [] rhs)
collect xs (_, AnnNote note e) = collect xs e
+collect xs (_, AnnCast 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)
schemeE d s p (AnnNote note (_, body))
= schemeE d s p body
+schemeE d s p (AnnCast (_, body) _)
+ = schemeE d s p body
+
schemeE d s p other
= pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' other))
-- things that are pointers, whereas in CgBindery the code builds the
-- bitmap from the free slots and unboxed bindings.
-- (ToDo: merge?)
- bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots)
+ --
+ -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
+ -- The bitmap must cover the portion of the stack up to the sequel only.
+ -- Previously we were building a bitmap for the whole depth (d), but we
+ -- really want a bitmap up to depth (d-s). This affects compilation of
+ -- case-of-case expressions, which is the only time we can be compiling a
+ -- case expression with s /= 0.
+ bitmap_size = d-s
+ bitmap = intsToReverseBitmap bitmap_size{-size-}
+ (sortLe (<=) (filter (< bitmap_size) 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 True{-is alts-}
+ 0{-no arity-} 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
ioToBc (mkMarshalCode cconv
(r_offW, r_rep) addr_offW
(zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
- recordMallocBc addr_of_marshaller `thenBc_`
+ recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) `thenBc_`
let
-- Offset of the next stack frame down the stack. The CCALL
-- instruction needs to describe the chunk of stack containing
stk_offset = d_after_r - s
-- do the call
- do_call = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
+ do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller))
-- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
`snocOL` RETURN_UBX r_rep
NonPtrArg -> MachWord 0
DoubleArg -> MachDouble 0
FloatArg -> MachFloat 0
+ LongArg -> MachWord64 0
_ -> moan64 "mkDummyLiteral" (ppr pr)
-- to be on the safe side we copy the string into
-- a malloc'd area of memory.
ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
- recordMallocBc ptr `thenBc_`
+ recordMallocBc ptr `thenBc_`
ioToBc (
withForeignPtr fp $ \p -> do
memcpy ptr p (fromIntegral n)
-- Get the addr on the stack, untaggedly
returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
+pushAtom d p (AnnCast e _)
+ = pushAtom d p (snd e)
+
pushAtom d p other
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, other)))
| otherwise = case splitApp f of
(f', as) -> (f', a:as)
splitApp (AnnNote n (_,e)) = splitApp e
+splitApp (AnnCast (_,e) _) = splitApp e
splitApp e = (e, [])
isVoidArgAtom :: AnnExpr' id ann -> Bool
isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg
isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e
+isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e
isVoidArgAtom _ = False
atomRep :: AnnExpr' Id ann -> CgRep
atomRep (AnnNote n b) = atomRep (snd b)
atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
+atomRep (AnnCast b _) = atomRep (snd b)
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
isPtrAtom :: AnnExpr' Id ann -> Bool
-- -----------------------------------------------------------------------------
-- The bytecode generator's monad
+type BcPtr = Either ItblPtr (Ptr ())
+
data BcM_State
= BcM_State {
nextlabel :: Int, -- for generating local labels
- malloced :: [Ptr ()] } -- ptrs malloced for current BCO
+ malloced :: [BcPtr] } -- thunks malloced for current BCO
-- Should be free()d when it is GCd
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
(>>) = thenBc_
return = returnBc
-emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
recordMallocBc :: Ptr a -> BcM ()
recordMallocBc a
- = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
+ = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
+
+recordItblMallocBc :: ItblPtr -> BcM ()
+recordItblMallocBc a
+ = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
getLabelBc :: BcM Int
getLabelBc
projects / ghc-hetmet.git / blobdiff