X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=b4d026a9f45799068916526e9bce61113e8d205e;hb=59e99f059c3b3f235fa12f19f15544ebf022f35b;hp=0c668b923f23b5b97801ec76fddbb1cd5255ba21;hpb=61288bed541f3486fdf5902388e9e33f32db97a7;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 0c668b9..b4d026a 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -5,15 +5,23 @@ ByteCodeGen: Generate bytecode from Core \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" import ByteCodeInstr import ByteCodeItbls -import ByteCodeFFI import ByteCodeAsm import ByteCodeLink +import ByteCodeFFI +import LibFFI import Outputable import Name @@ -48,9 +56,8 @@ import OrdList import Constants import Data.List ( intersperse, sortBy, zip4, zip6, partition ) -import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, - withForeignPtr, castFunPtrToPtr ) -import Foreign.C ( CInt ) +import Foreign +import Foreign.C import Control.Exception ( throwDyn ) import GHC.Exts ( Int(..), ByteArray# ) @@ -58,21 +65,29 @@ import GHC.Exts ( Int(..), ByteArray# ) import Control.Monad ( when ) import Data.Char ( ord, chr ) +import UniqSupply +import BreakArray +import Data.Maybe +import Module +import IdInfo + -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module byteCodeGen :: DynFlags -> [CoreBind] -> [TyCon] + -> ModBreaks -> IO CompiledByteCode -byteCodeGen dflags binds tycs +byteCodeGen dflags binds tycs modBreaks = do showPass dflags "ByteCodeGen" let flatBinds = [ (bndr, freeVars rhs) | (bndr, rhs) <- flattenBinds binds] - (BcM_State final_ctr mallocd, proto_bcos) - <- runBc (mapM schemeTopBind flatBinds) + us <- mkSplitUniqSupply 'y' + (BcM_State _us final_ctr mallocd _, proto_bcos) + <- runBc us modBreaks (mapM schemeTopBind flatBinds) when (notNull mallocd) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") @@ -95,11 +110,14 @@ coreExprToBCOs dflags expr -- 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") + let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") invented_id = Id.mkLocalId invented_name (panic "invented_id's type") - (BcM_State final_ctr mallocd, proto_bco) - <- runBc (schemeTopBind (invented_id, freeVars expr)) + -- the uniques are needed to generate fresh variables when we introduce new + -- let bindings for ticked expressions + us <- mkSplitUniqSupply 'y' + (BcM_State _us final_ctr mallocd _ , proto_bco) + <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr)) when (notNull mallocd) (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") @@ -141,8 +159,7 @@ mkProtoBCO -> Bool -- True <=> is a return point, rather than a function -> [BcPtr] -> ProtoBCO name -mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap - is_ret mallocd_blocks +mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks = ProtoBCO { protoBCOName = nm, protoBCOInstrs = maybe_with_stack_check, @@ -161,17 +178,19 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap -- (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; + | is_ret && stack_usage < aP_STACK_SPLIM = 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 >= iNTERP_STACK_CHECK_THRESH - = STKCHECK stack_overest : peep_d + -- (which must be a function). + -- That is, unless the stack usage is >= AP_STACK_SPLIM, + -- see bug #1466. + | stack_usage >= iNTERP_STACK_CHECK_THRESH + = STKCHECK stack_usage : peep_d | otherwise = peep_d -- the supposedly common case -- We assume that this sum doesn't wrap - stack_overest = sum (map bciStackUse peep_d) + stack_usage = sum (map bciStackUse peep_d) -- Merge local pushes peep_d = peep (fromOL instrs_ordlist) @@ -199,22 +218,24 @@ argBits (rep : args) schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) -schemeTopBind (id, rhs) +schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, - isNullaryRepDataCon data_con - = -- Special case for the worker of a nullary data con. + isNullaryRepDataCon data_con = do + -- 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. + -- ioToBc (putStrLn $ "top level BCO") emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER]) - (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise = schemeR [{- No free variables -}] (id, rhs) + -- ----------------------------------------------------------------------------- -- schemeR @@ -232,7 +253,7 @@ schemeR :: [Id] -- Free vars of the RHS, ordered as they -- top-level things, which have no free vars. -> (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) -schemeR fvs (nm, rhs) +schemeR fvs (nm, rhs) {- | trace (showSDoc ( (char ' ' @@ -245,11 +266,13 @@ schemeR fvs (nm, rhs) -} = schemeR_wrk fvs nm rhs (collect [] rhs) +collect :: [Var] -> AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) 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) +schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) = let all_args = reverse args ++ fvs @@ -267,10 +290,37 @@ schemeR_wrk fvs nm original_body (args, body) bitmap_size = length bits bitmap = mkBitmap bits in do - body_code <- schemeE szw_args 0 p_init body + body_code <- schemeER_wrk szw_args p_init body + emitBc (mkProtoBCO (getName nm) body_code (Right original_body) arity bitmap_size bitmap False{-not alts-}) +-- introduce break instructions for ticked expressions +schemeER_wrk :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList +schemeER_wrk d p rhs + | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do + code <- schemeE d 0 p newRhs + arr <- getBreakArray + let idOffSets = getVarOffSets d p tickInfo + let tickNumber = tickInfo_number tickInfo + let breakInfo = BreakInfo + { breakInfo_module = tickInfo_module tickInfo + , breakInfo_number = tickNumber + , breakInfo_vars = idOffSets + , breakInfo_resty = exprType (deAnnotate' newRhs) + } + let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo + return $ breakInstr `consOL` code + | otherwise = schemeE d 0 p rhs + +getVarOffSets :: Int -> BCEnv -> TickInfo -> [(Id, Int)] +getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals + +getOffSet :: Int -> BCEnv -> Id -> Maybe (Id, Int) +getOffSet d env id + = case lookupBCEnv_maybe env id of + Nothing -> Nothing + Just offset -> Just (id, d - offset) fvsToEnv :: BCEnv -> VarSet -> [Id] -- Takes the free variables of a right-hand side, and @@ -288,6 +338,18 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs, -- ----------------------------------------------------------------------------- -- schemeE +data TickInfo + = TickInfo + { tickInfo_number :: Int -- the (module) unique number of the tick + , tickInfo_module :: Module -- the origin of the ticked expression + , tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression + } + +instance Outputable TickInfo where + ppr info = text "TickInfo" <+> + parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+> + ppr (tickInfo_locals info)) + -- 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 @@ -365,9 +427,15 @@ schemeE d s p (AnnLet binds (_,body)) return (push_code `appOL` more_push_code) alloc_code = toOL (zipWith mkAlloc sizes arities) - where mkAlloc sz 0 = ALLOC_AP sz + where mkAlloc sz 0 + | is_tick = ALLOC_AP_NOUPD sz + | otherwise = ALLOC_AP sz mkAlloc sz arity = ALLOC_PAP arity sz + is_tick = case binds of + AnnNonRec id _ -> occNameFS (getOccName id) == tickFS + _other -> False + compile_bind d' fvs x rhs size arity off = do bco <- schemeR fvs (x,rhs) build_thunk d' fvs size bco off arity @@ -382,7 +450,24 @@ schemeE d s p (AnnLet binds (_,body)) thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) - +-- introduce a let binding for a ticked case expression. This rule +-- *should* only fire when the expression was not already let-bound +-- (the code gen for let bindings should take care of that). Todo: we +-- call exprFreeVars on a deAnnotated expression, this may not be the +-- best way to calculate the free vars but it seemed like the least +-- intrusive thing to do +schemeE d s p exp@(AnnCase {}) + | Just (tickInfo,rhs) <- isTickedExp' exp + = if isUnLiftedType ty + then schemeE d s p (snd rhs) + else do + id <- newId ty + -- Todo: is emptyVarSet correct on the next line? + let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id) + schemeE d s p letExp + where exp' = deAnnotate' exp + fvs = exprFreeVars exp' + ty = exprType exp' schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) @@ -396,11 +481,11 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) -- envt (it won't be bound now) because we never look such things up. = --trace "automagic mashing of case alts (# VoidArg, a #)" $ - doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) = --trace "automagic mashing of case alts (# a, VoidArg #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc @@ -409,10 +494,10 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) -- to -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr _ alts) - = doCase d s p scrut bndr alts False{-not an unboxed tuple-} + = doCase d s p scrut bndr alts False{-not an unboxed tuple-} schemeE d s p (AnnNote note (_, body)) = schemeE d s p body @@ -424,6 +509,56 @@ schemeE d s p other = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' other)) +{- + Ticked Expressions + ------------------ + + A ticked expression looks like this: + + case tick var1 ... varN of DEFAULT -> e + + (*) is the number of the tick, which is unique within a module + (*) var1 ... varN are the local variables in scope at the tick site + + If we find a ticked expression we return: + + Just ((n, [var1 ... varN]), e) + + otherwise we return Nothing. + + The idea is that the "case tick ..." is really just an annotation on + the code. When we find such a thing, we pull out the useful information, + and then compile the code as if it was just the expression "e". + +-} + +isTickedExp :: AnnExpr Id a -> Maybe (TickInfo, AnnExpr Id a) +isTickedExp (annot, expr) = isTickedExp' expr + +isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a) +isTickedExp' (AnnCase scrut _bndr _type alts) + | Just tickInfo <- isTickedScrut scrut, + [(DEFAULT, _bndr, rhs)] <- alts + = Just (tickInfo, rhs) + where + isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo + isTickedScrut expr + | Var id <- f, + Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id + = Just $ TickInfo { tickInfo_number = tickNumber + , tickInfo_module = modName + , tickInfo_locals = idsOfArgs args + } + | otherwise = Nothing + where + (f, args) = collectArgs $ deAnnotate expr + idsOfArgs :: [Expr Id] -> [Id] + idsOfArgs = catMaybes . map exprId + exprId :: Expr Id -> Maybe Id + exprId (Var id) = Just id + exprId other = Nothing + +isTickedExp' other = Nothing -- Compile code to do a tail call. Specifically, push the fn, -- slide the on-stack app back down to the sequel depth, @@ -640,8 +775,7 @@ doCase :: Int -> Sequel -> BCEnv -> 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. @@ -670,9 +804,10 @@ doCase d s p (_,scrut) 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)) = do rhs_code <- schemeE d_alts s p_alts rhs return (NoDiscr, rhs_code) + codeAlt alt@(discr, bndrs, (_,rhs)) -- primitive or nullary constructor alt: no need to UNPACK | null real_bndrs = do @@ -696,7 +831,6 @@ doCase d s p (_,scrut) where real_bndrs = filter (not.isTyVar) bndrs - my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, binds, rhs) | isUnboxedTupleCon dc @@ -745,6 +879,7 @@ doCase d s p (_,scrut) in do alt_stuff <- mapM codeAlt alts alt_final <- mkMultiBranch maybe_ncons alt_stuff + let alt_bco_name = getName bndr alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) @@ -797,18 +932,18 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep arrPtrsHdrSize d p a - return ((code,NonPtrArg):rest) + return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep arrWordsHdrSize d p a - return ((code,NonPtrArg):rest) + return ((code,AddrRep):rest) -- Default case: push taggedly, but otherwise intact. other -> do (code_a, sz_a) <- pushAtom d p a rest <- pargs (d+sz_a) az - return ((code_a, atomRep a) : rest) + return ((code_a, atomPrimRep a) : rest) -- Do magic for Ptr/Byte arrays. Push a ptr to the array on -- the stack but then advance it over the headers, so as to @@ -825,9 +960,9 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps push_args = concatOL pushs_arg - d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l) + d_after_args = d0 + sum (map primRepSizeW a_reps_pushed_r_to_l) a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep = panic "ByteCodeGen.generateCCall: missing or invalid World token?" | otherwise = reverse (tail a_reps_pushed_r_to_l) @@ -839,7 +974,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Get the result rep. (returns_void, r_rep) = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, VoidArg) + Nothing -> (True, VoidRep) Just rr -> (False, rr) {- Because the Haskell stack grows down, the a_reps refer to @@ -905,7 +1040,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Push the return placeholder. For a call returning nothing, -- this is a VoidArg (tag). - r_sizeW = cgRepSizeW r_rep + r_sizeW = primRepSizeW r_rep d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -917,24 +1052,28 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l addr_offW = r_sizeW arg1_offW = r_sizeW + addr_sizeW args_offW = map (arg1_offW +) - (init (scanl (+) 0 (map cgRepSizeW a_reps))) - -- in - addr_of_marshaller <- ioToBc (mkMarshalCode cconv - (r_offW, r_rep) addr_offW - (zip args_offW a_reps)) - recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) - let + (init (scanl (+) 0 (map primRepSizeW a_reps))) + -- Offset of the next stack frame down the stack. The CCALL -- 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 + -- in + -- the only difference in libffi mode is that we prepare a cif + -- describing the call type by calling libffi, and we attach the + -- address of this to the CCALL instruction. + token <- ioToBc $ prepForeignCall cconv a_reps r_rep + let addr_of_marshaller = castPtrToFunPtr token + + recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) + let -- do the call 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 + `snocOL` RETURN_UBX (primRepToCgRep r_rep) --in --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ return ( @@ -942,17 +1081,19 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) - -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. -mkDummyLiteral :: CgRep -> Literal +mkDummyLiteral :: PrimRep -> Literal mkDummyLiteral pr = case pr of - NonPtrArg -> MachWord 0 - DoubleArg -> MachDouble 0 - FloatArg -> MachFloat 0 - LongArg -> MachWord64 0 - _ -> moan64 "mkDummyLiteral" (ppr pr) + IntRep -> MachInt 0 + WordRep -> MachWord 0 + AddrRep -> MachNullAddr + DoubleRep -> MachDouble 0 + FloatRep -> MachFloat 0 + Int64Rep -> MachInt64 0 + Word64Rep -> MachWord64 0 + _ -> panic "mkDummyLiteral" -- Convert (eg) @@ -969,21 +1110,21 @@ mkDummyLiteral pr -- -- to Nothing -maybe_getCCallReturnRep :: Type -> Maybe CgRep +maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) (r_tycon, r_reps) = case splitTyConApp_maybe (repType r_ty) of - (Just (tyc, tys)) -> (tyc, map typeCgRep tys) + (Just (tyc, tys)) -> (tyc, map typePrimRep tys) Nothing -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps) - || r_reps == [VoidArg] ) + ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) + || r_reps == [VoidRep] ) && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True - Just r_rep -> r_rep /= PtrArg + Just r_rep -> r_rep /= PtrRep -- if it was, it would be impossible -- to create a valid return value -- placeholder on the stack @@ -1119,7 +1260,7 @@ pushAtom d p other (pprCoreExpr (deAnnotate (undefined, other))) foreign import ccall unsafe "memcpy" - memcpy :: Ptr a -> Ptr b -> CInt -> IO () + memcpy :: Ptr a -> Ptr b -> CSize -> IO () -- ----------------------------------------------------------------------------- @@ -1256,13 +1397,14 @@ lookupBCEnv_maybe = lookupFM idSizeW :: Id -> Int idSizeW id = cgRepSizeW (typeCgRep (idType id)) +-- See bug #1257 unboxedTupleException :: a unboxedTupleException = throwDyn - (Panic - ("Bytecode generator can't handle unboxed tuples. Possibly due\n" ++ - "\tto foreign import/export decls in source. Workaround:\n" ++ - "\tcompile this module to a .o file, then restart session.")) + (ProgramError + ("Error: bytecode compiler can't handle unboxed tuples.\n"++ + " Possibly due to foreign import/export decls in source.\n"++ + " Workaround: use -fobject-code, or compile this module to .o separately.")) mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) @@ -1284,19 +1426,22 @@ isTypeAtom (AnnType _) = True isTypeAtom _ = False isVoidArgAtom :: AnnExpr' id ann -> Bool -isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e isVoidArgAtom _ = False +atomPrimRep :: AnnExpr' Id ann -> PrimRep +atomPrimRep (AnnVar v) = typePrimRep (idType v) +atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnNote n b) = atomPrimRep (snd b) +atomPrimRep (AnnApp f (_, AnnType _)) = atomPrimRep (snd f) +atomPrimRep (AnnLam x e) | isTyVar x = atomPrimRep (snd e) +atomPrimRep (AnnCast b _) = atomPrimRep (snd b) +atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) + atomRep :: AnnExpr' Id ann -> CgRep -atomRep (AnnVar v) = typeCgRep (idType v) -atomRep (AnnLit l) = typeCgRep (literalType 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 (AnnCast b _) = atomRep (snd b) -atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) +atomRep e = primRepToCgRep (atomPrimRep e) isPtrAtom :: AnnExpr' Id ann -> Bool isPtrAtom e = atomRep e == PtrArg @@ -1315,9 +1460,12 @@ type BcPtr = Either ItblPtr (Ptr ()) data BcM_State = BcM_State { + uniqSupply :: UniqSupply, -- for generating fresh variable names nextlabel :: Int, -- for generating local labels - malloced :: [BcPtr] } -- thunks malloced for current BCO + malloced :: [BcPtr], -- thunks malloced for current BCO -- Should be free()d when it is GCd + breakArray :: BreakArray -- array of breakpoint flags + } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) @@ -1326,8 +1474,11 @@ ioToBc io = BcM $ \st -> do x <- io return (st, x) -runBc :: BcM r -> IO (BcM_State, r) -runBc (BcM m) = m (BcM_State 0 []) +runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r) +runBc us modBreaks (BcM m) + = m (BcM_State us 0 [] breakArray) + where + breakArray = modBreaks_flags modBreaks thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -1370,4 +1521,20 @@ getLabelsBc :: Int -> BcM [Int] getLabelsBc n = BcM $ \st -> let ctr = nextlabel st in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) + +getBreakArray :: BcM BreakArray +getBreakArray = BcM $ \st -> return (st, breakArray st) + +newUnique :: BcM Unique +newUnique = BcM $ + \st -> case splitUniqSupply (uniqSupply st) of + (us1, us2) -> let newState = st { uniqSupply = us2 } + in return (newState, uniqFromSupply us1) + +newId :: Type -> BcM Id +newId ty = do + uniq <- newUnique + return $ mkSysLocal tickFS uniq ty + +tickFS = fsLit "ticked" \end{code}