X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=485a2851ce1b46bd3b1d283c4a11c8036bc98abd;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=faed478a576aabebedc14ccdc856668bc88a430c;hpb=0bffc410964e1688ad80d277d53400659e697ab5;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index faed478..485a285 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -19,38 +19,36 @@ import Name ( Name, getName, mkSystemName ) 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 Literal ( Literal(..), literalPrimRep ) -import PrimRep +import Literal ( Literal(..), literalType ) import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, - isTyVarTy ) +import Type ( 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 CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) -import Unique ( mkPseudoUnique3 ) +import Unique ( mkPseudoUniqueE ) import FastString ( FastString(..), unpackFS ) import Panic ( GhcException(..) ) -import PprType ( pprType ) -import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) +import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord, + CgRep(..), cgRepSizeW, isFollowableArg, idCgRep ) +import Bitmap ( intsToReverseBitmap, mkBitmap ) import OrdList import Constants ( wORD_SIZE ) @@ -61,30 +59,27 @@ import Control.Exception ( throwDyn ) 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?") @@ -107,14 +102,11 @@ 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 = 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 (mkPseudoUniqueE 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?") @@ -141,7 +133,7 @@ ppBCEnv p $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p)))) $$ text "end-env" where - pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idPrimRep var) + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var) cmp_snd x y = compare (snd x) (snd y) -- Create a BCO and do a spot of peephole optimisation on the insns @@ -153,9 +145,11 @@ mkProtoBCO -> 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, @@ -174,16 +168,19 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mallocd_blocks -- (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) @@ -197,48 +194,54 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mallocd_blocks peep [] = [] -argBits :: [PrimRep] -> [Bool] +argBits :: [CgRep] -> [Bool] argBits [] = [] argBits (rep : args) - | 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 = complement 0 - | otherwise = (1 `shiftL` size) - 1 - -wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int + | isFollowableArg rep = False : argBits args + | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args + +-- ----------------------------------------------------------------------------- +-- 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 ' ' @@ -247,30 +250,19 @@ schemeR is_top fvs (nm, rhs) $$ 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 @@ -279,48 +271,43 @@ schemeR_wrk is_top fvs original_body nm (args, body) p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap - bits = argBits (reverse (map idPrimRep all_args)) + bits = argBits (reverse (map idCgRep all_args)) bitmap_size = length bits bitmap = mkBitmap bits 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. @@ -331,110 +318,38 @@ schemeE d s p e@(fvs, AnnVar v) `snocOL` RETURN_UBX v_rep) -- go where v_type = idType v - v_rep = typePrimRep v_type + v_rep = typeCgRep 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 + let l_rep = typeCgRep (literalType literal) in returnBc (push -- value onto stack `appOL` mkSLIDE szw (d-s) -- clear to sequel `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 @@ -450,7 +365,7 @@ schemeE d s p (fvs, AnnLet binds b) -- 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 @@ -461,7 +376,7 @@ schemeE d s p (fvs, AnnLet binds b) 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 = @@ -470,16 +385,16 @@ schemeE d s p (fvs, AnnLet binds b) 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)]) - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) +schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) -- Convert - -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- case .... of x { (# VoidArg'd-thing, a #) -> ... } -- to -- case .... of a { DEFAULT -> ... } -- becuse the return convention for both are identical. @@ -487,14 +402,14 @@ schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. - = --trace "automagic mashing of case alts (# VoidRep, a #)" $ + = --trace "automagic mashing of case alts (# VoidArg, a #)" $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind2) - = --trace "automagic mashing of case alts (# a, VoidRep #)" $ + | 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-} -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 #) -> ... } @@ -503,15 +418,15 @@ schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) = --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, @@ -523,27 +438,24 @@ schemeE d s p other -- 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 +-- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat -- it simply as b -- since the representations are identical --- (the VoidRep takes up zero stack space). Also, spot +-- (the VoidArg 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 @@ -551,7 +463,7 @@ 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 @@ -563,28 +475,27 @@ schemeT d s p app `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] | isVoidArgAtom arg1 -> + unboxedTupleReturn d s p arg2 + [arg1,arg2] | isVoidArgAtom 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 @@ -592,64 +503,66 @@ schemeT d s p app -- 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 @@ -675,7 +588,7 @@ doTailCall -> Id -> [AnnExpr' Id VarSet] -> BcM BCInstrList doTailCall init_d s p fn args - = do_pushes init_d args (map (primRepToArgRep.atomRep) args) + = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do ASSERTM( null reps ) @@ -699,29 +612,29 @@ doTailCall init_d s p fn args return (final_d, push_code `appOL` more_push_code) -- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPPPP, 7, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: rest) = (PUSH_APPLY_PP, 2, rest) -findPushSeq (RepP: rest) +findPushSeq (PtrArg: rest) = (PUSH_APPLY_P, 1, rest) -findPushSeq (RepV: rest) +findPushSeq (VoidArg: rest) = (PUSH_APPLY_V, 1, rest) -findPushSeq (RepN: rest) +findPushSeq (NonPtrArg: rest) = (PUSH_APPLY_N, 1, rest) -findPushSeq (RepF: rest) +findPushSeq (FloatArg: rest) = (PUSH_APPLY_F, 1, rest) -findPushSeq (RepD: rest) +findPushSeq (DoubleArg: rest) = (PUSH_APPLY_D, 1, rest) -findPushSeq (RepL: rest) +findPushSeq (LongArg: rest) = (PUSH_APPLY_L, 1, rest) findPushSeq _ = panic "ByteCodeGen.findPushSeq" @@ -733,7 +646,8 @@ 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. @@ -762,10 +676,10 @@ doCase d s p scrut bndr alts is_unboxed_tuple 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 @@ -773,7 +687,7 @@ doCase d s p scrut bndr alts is_unboxed_tuple -- algebraic alt with some binders | ASSERT(isAlgCase) otherwise = let - (ptrs,nptrs) = partition (isFollowableRep.idPrimRep) real_bndrs + (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs ptr_sizes = map idSizeW ptrs nptrs_sizes = map idSizeW nptrs bind_sizes = ptr_sizes ++ nptrs_sizes @@ -799,7 +713,7 @@ doCase d s p scrut bndr alts is_unboxed_tuple = 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 @@ -816,12 +730,12 @@ doCase d s p scrut bndr alts is_unboxed_tuple -- 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-} (sortLe (<=) rel_slots) where binds = fmToList p rel_slots = concat (map spread binds) spread (id, offset) - | isFollowableRep (idPrimRep id) = [ rel_offset ] + | isFollowableArg (idCgRep id) = [ rel_offset ] | otherwise = [] where rel_offset = d - offset - 1 @@ -831,7 +745,7 @@ doCase d s p scrut bndr alts is_unboxed_tuple 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 @@ -839,7 +753,7 @@ doCase d s p scrut bndr alts is_unboxed_tuple alt_bco' <- emitBc alt_bco let push_alts | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typePrimRep bndr_ty) + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) returnBc (push_alts `consOL` scrut_code) @@ -847,8 +761,8 @@ doCase d s p scrut bndr alts is_unboxed_tuple -- 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. @@ -862,12 +776,12 @@ generateCCall :: Int -> Sequel -- stack and sequel depths generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = let -- useful constants - addr_sizeW = getPrimRepSize AddrRep + addr_sizeW = cgRepSizeW NonPtrArg -- Get the args on the stack, with tags and suitably -- dereferenced for the CCall. For each arg, return the -- depth to the first word of the bits for that arg, and the - -- PrimRep of what was actually pushed. + -- CgRep of what was actually pushed. pargs d [] = returnBc [] pargs d (a:az) @@ -881,13 +795,13 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrPtrsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrWordsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) -- Default case: push taggedly, but otherwise intact. other @@ -898,13 +812,11 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- 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 -- point to the payload. - parg_ArrayishRep hdrSizeW d p a + parg_ArrayishRep hdrSize d p a = pushAtom d p a `thenBc` \ (push_fo, _) -> -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. - returnBc (push_fo `snocOL` - SWIZZLE 0 (hdrSizeW * getPrimRepSize WordRep - * wORD_SIZE)) + returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize) in pargs d0 args_r_to_l `thenBc` \ code_n_reps -> @@ -912,9 +824,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 getPrimRepSize a_reps_pushed_r_to_l) + d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l) a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg = panic "ByteCodeGen.generateCCall: missing or invalid World token?" | otherwise = reverse (tail a_reps_pushed_r_to_l) @@ -926,7 +838,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, VoidRep) + Nothing -> (True, VoidArg) Just rr -> (False, rr) {- Because the Haskell stack grows down, the a_reps refer to @@ -953,8 +865,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l 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 @@ -972,8 +883,6 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l 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 @@ -994,8 +903,8 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, - -- this is a VoidRep (tag). - r_sizeW = getPrimRepSize r_rep + -- this is a VoidArg (tag). + r_sizeW = cgRepSizeW r_rep d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -1007,7 +916,7 @@ 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 getPrimRepSize a_reps))) + (init (scanl (+) 0 (map cgRepSizeW a_reps))) in ioToBc (mkMarshalCode cconv (r_offW, r_rep) addr_offW @@ -1015,13 +924,9 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l 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 @@ -1030,7 +935,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) `snocOL` RETURN_UBX r_rep in - --trace (show (arg1_offW, args_offW , (map getPrimRepSize a_reps) )) $ + --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ returnBc ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup @@ -1039,15 +944,12 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. -mkDummyLiteral :: PrimRep -> Literal +mkDummyLiteral :: CgRep -> Literal mkDummyLiteral pr = case pr of - CharRep -> MachChar 0 - IntRep -> MachInt 0 - WordRep -> MachWord 0 - DoubleRep -> MachDouble 0 - FloatRep -> MachFloat 0 - AddrRep | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0 + NonPtrArg -> MachWord 0 + DoubleArg -> MachDouble 0 + FloatArg -> MachFloat 0 _ -> moan64 "mkDummyLiteral" (ppr pr) @@ -1056,7 +958,7 @@ mkDummyLiteral pr -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- -- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. +-- and check that an unboxed pair is returned wherein the first arg is VoidArg'd. -- -- Alternatively, for call-targets returning nothing, convert -- @@ -1065,21 +967,21 @@ mkDummyLiteral pr -- -- to Nothing -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> Maybe CgRep 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 typePrimRep tys) + (Just (tyc, tys)) -> (tyc, map typeCgRep tys) Nothing -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) - || r_reps == [VoidRep] ) + ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps) + || r_reps == [VoidArg] ) && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True - Just r_rep -> r_rep /= PtrRep + Just r_rep -> r_rep /= PtrArg -- if it was, it would be impossible -- to create a valid return value -- placeholder on the stack @@ -1139,7 +1041,7 @@ pushAtom d p (AnnLam x e) pushAtom d p (AnnVar v) - | idPrimRep v == VoidRep + | idCgRep v == VoidArg = returnBc (nilOL, 0) | isFCallId v @@ -1148,8 +1050,8 @@ pushAtom d p (AnnVar v) | 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 -- @@ -1160,33 +1062,27 @@ pushAtom d p (AnnVar v) -- -- 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 NonPtrArg + MachWord w -> code NonPtrArg + MachInt i -> code PtrArg + MachFloat r -> code FloatArg + MachDouble r -> code DoubleArg + MachChar c -> code NonPtrArg + MachStr s -> pushStr s where code rep - = let size_host_words = getPrimRepSize rep + = let size_host_words = cgRepSizeW rep in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) @@ -1354,7 +1250,7 @@ lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int lookupBCEnv_maybe = lookupFM idSizeW :: Id -> Int -idSizeW id = getPrimRepSize (typePrimRep (idType id)) +idSizeW id = cgRepSizeW (typeCgRep (idType id)) unboxedTupleException :: a unboxedTupleException @@ -1368,23 +1264,36 @@ unboxedTupleException 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 -isVoidRepAtom :: AnnExpr' id ann -> Bool -isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep -isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e -isVoidRepAtom _ = False +isVoidArgAtom :: AnnExpr' id ann -> Bool +isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e +isVoidArgAtom _ = False -atomRep :: AnnExpr' Id ann -> PrimRep -atomRep (AnnVar v) = typePrimRep (idType v) -atomRep (AnnLit l) = literalPrimRep l +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 other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) +isPtrAtom :: AnnExpr' Id ann -> Bool +isPtrAtom e = atomRep e == PtrArg + -- 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. @@ -1408,10 +1317,8 @@ ioToBc io = BcM $ \st -> do 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