X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=a9e3c07524158f17ae055e67e01d266906547738;hb=85f8276b368d39c93e137fa7b0a8a96ab3c6b389;hp=b45a64318efbd5fe335e8bd6a8249e2fa9a78d5a;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index b45a643..a9e3c07 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -166,7 +166,7 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit -- stack check. (The interpreter always does a stack check -- for iNTERP_STACK_CHECK_THRESH words at the start of each - -- BCO anyway, so we only need to add an explicit on in the + -- BCO anyway, so we only need to add an explicit one in the -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. maybe_with_stack_check @@ -256,13 +256,14 @@ schemeR fvs (nm, rhs) = undefined | otherwise -} - = schemeR_wrk fvs nm rhs (collect [] rhs) + = schemeR_wrk fvs nm rhs (collect rhs) -collect :: [Var] -> AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) -collect xs (_, AnnNote _ 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) +collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) +collect (_, e) = go [] e + where + go xs e | Just e' <- bcView e = go xs e' + go xs (AnnLam x (_,e)) = go (x:xs) e + go 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) @@ -346,6 +347,10 @@ instance Outputable TickInfo where -- on the stack, returning a HNF. schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList +schemeE d s p e + | Just e' <- bcView e + = schemeE d s p e' + -- Delegate tail-calls to schemeT. schemeE d s p e@(AnnApp _ _) = schemeT d s p e @@ -397,7 +402,7 @@ schemeE d s p (AnnLet binds (_,body)) sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss -- the arity of each rhs - arities = map (length . fst . collect []) rhss + arities = map (length . fst . collect) rhss -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1. d' and p' reflect the stack @@ -491,12 +496,6 @@ schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)]) schemeE d s p (AnnCase scrut bndr _ alts) = doCase d s p scrut bndr alts False{-not an unboxed tuple-} -schemeE d s p (AnnNote _ (_, body)) - = schemeE d s p body - -schemeE d s p (AnnCast (_, body) _) - = schemeE d s p body - schemeE _ _ _ expr = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' expr)) @@ -1169,18 +1168,11 @@ implement_tagToId names pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int) -pushAtom d p (AnnApp f (_, AnnType _)) - = pushAtom d p (snd f) - -pushAtom d p (AnnNote _ e) - = pushAtom d p (snd e) - -pushAtom d p (AnnLam x e) - | isTyVar x - = pushAtom d p (snd e) +pushAtom d p e + | Just e' <- bcView e + = pushAtom d p e' pushAtom d p (AnnVar v) - | idCgRep v == VoidArg = return (nilOL, 0) @@ -1219,6 +1211,7 @@ pushAtom _ _ (AnnLit lit) MachFloat _ -> code FloatArg MachDouble _ -> code DoubleArg MachChar _ -> code NonPtrArg + MachNullAddr -> code NonPtrArg MachStr s -> pushStr s l -> pprPanic "pushAtom" (ppr l) where @@ -1410,34 +1403,37 @@ unboxedTupleException mkSLIDE :: Int -> Int -> OrdList BCInstr mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) -splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann]) +splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var 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 _ (_,e)) = splitApp e -splitApp (AnnCast (_,e) _) = splitApp e -splitApp e = (e, []) - - -isTypeAtom :: AnnExpr' id ann -> Bool -isTypeAtom (AnnType _) = True -isTypeAtom _ = False - -isVoidArgAtom :: AnnExpr' id ann -> Bool -isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep -isVoidArgAtom (AnnNote _ (_,e)) = isVoidArgAtom e -isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e -isVoidArgAtom _ = False +splitApp e | Just e' <- bcView e = splitApp e' +splitApp (AnnApp (_,f) (_,a)) = case splitApp f of + (f', as) -> (f', a:as) +splitApp e = (e, []) + + +bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) +-- The "bytecode view" of a term discards +-- a) type abstractions +-- b) type applications +-- c) casts +-- d) notes +-- Type lambdas *can* occur in random expressions, +-- whereas value lambdas cannot; that is why they are nuked here +bcView (AnnNote _ (_,e)) = Just e +bcView (AnnCast (_,e) _) = Just e +bcView (AnnLam v (_,e)) | isTyVar v = Just e +bcView (AnnApp (_,e) (_, AnnType _)) = Just e +bcView _ = Nothing + +isVoidArgAtom :: AnnExpr' Var ann -> Bool +isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e' +isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep +isVoidArgAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep -atomPrimRep (AnnVar v) = typePrimRep (idType v) -atomPrimRep (AnnLit l) = typePrimRep (literalType l) -atomPrimRep (AnnNote _ 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 e | Just e' <- bcView e = atomPrimRep e' +atomPrimRep (AnnVar v) = typePrimRep (idType v) +atomPrimRep (AnnLit l) = typePrimRep (literalType l) atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) atomRep :: AnnExpr' Id ann -> CgRep