X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeInstr.lhs;h=7bd4408fff66895ef648332df7649ac74a236a9b;hb=beb5737b7ee42c4e9373a505e7d957206d69a30e;hp=dcc96d98950a351a00dc5a844ad13fe1e2cc6b95;hpb=5df78042458dc002b72b9b20f1e43ab28bff9ada;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index dcc96d9..7bd4408 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -4,10 +4,12 @@ \section[ByteCodeInstrs]{Bytecode instruction definitions} \begin{code} -module ByteCodeInstr ( BCInstr(..), ProtoBCO(..), - nameOfProtoBCO, bciStackUse ) where +module ByteCodeInstr ( + BCInstr(..), ProtoBCO(..), bciStackUse + ) where #include "HsVersions.h" +#include "../includes/MachDeps.h" import Outputable import Name ( Name ) @@ -15,69 +17,81 @@ import Id ( Id ) import CoreSyn import PprCore ( pprCoreExpr, pprCoreAlt ) import Literal ( Literal ) -import PrimRep ( PrimRep ) import DataCon ( DataCon ) import VarSet ( VarSet ) import PrimOp ( PrimOp ) -import Foreign ( Addr ) +import SMRep ( StgWord, CgRep ) +import GHC.Ptr -\end{code} - -%************************************************************************ -%* * -\subsection{Bytecodes, and Outputery.} -%* * -%************************************************************************ - -\begin{code} +-- ---------------------------------------------------------------------------- +-- Bytecode instructions data ProtoBCO a - = ProtoBCO a -- name, in some sense - [BCInstr] -- instrs - -- what the BCO came from - (Either [AnnAlt Id VarSet] - (AnnExpr Id VarSet)) - [Addr] -- malloc'd; free when BCO is GCd - -nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm + = ProtoBCO { + protoBCOName :: a, -- name, in some sense + protoBCOInstrs :: [BCInstr], -- instrs + -- arity and GC info + protoBCOBitmap :: [StgWord], + protoBCOBitmapSize :: Int, + protoBCOArity :: Int, + -- what the BCO came from + protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet), + -- malloc'd pointers + protoBCOPtrs :: [Ptr ()] + } type LocalLabel = Int data BCInstr -- Messing with the stack - = ARGCHECK Int - | STKCHECK Int + = STKCHECK Int + -- Push locals (existing bits of the stack) | PUSH_L Int{-offset-} | PUSH_LL Int Int{-2 offsets-} | PUSH_LLL Int Int Int{-3 offsets-} - -- Push a ptr - | PUSH_G (Either Name PrimOp) + + -- Push a ptr (these all map to PUSH_G really) + | PUSH_G Name + | PUSH_PRIMOP PrimOp + | PUSH_BCO (ProtoBCO Name) + -- Push an alt continuation - | PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info - -- PrimRep so we know which itbl + | PUSH_ALTS (ProtoBCO Name) + | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep + -- Pushing literals - | PUSH_UBX (Either Literal Addr) - Int -- push this int/float/double/addr, NO TAG, on the stack - -- Int is # of words to copy from literal pool - -- Eitherness reflects the difficulty of dealing with - -- MachAddr here, mostly due to the excessive - -- (and unnecessary) restrictions imposed by the designers - -- of the new Foreign library. In particular it is quite - -- impossible to convert an Addr to any other integral type, - -- and it appears impossible to get hold of the bits of an - -- addr, even though we need to to assemble BCOs. - - | PUSH_TAG Int -- push this tag on the stack + | PUSH_UBX (Either Literal (Ptr ())) Int + -- push this int/float/double/addr, on the stack. Int + -- is # of words to copy from literal pool. Eitherness reflects + -- the difficulty of dealing with MachAddr here, mostly due to + -- the excessive (and unnecessary) restrictions imposed by the + -- designers of the new Foreign library. In particular it is + -- quite impossible to convert an Addr to any other integral + -- type, and it appears impossible to get hold of the bits of + -- an addr, even though we need to to assemble BCOs. + + -- various kinds of application + | PUSH_APPLY_N + | PUSH_APPLY_V + | PUSH_APPLY_F + | PUSH_APPLY_D + | PUSH_APPLY_L + | PUSH_APPLY_P + | PUSH_APPLY_PP + | PUSH_APPLY_PPP + | PUSH_APPLY_PPPP + | PUSH_APPLY_PPPPP + | PUSH_APPLY_PPPPPP | SLIDE Int{-this many-} Int{-down by this much-} + -- To do with the heap - | ALLOC Int -- make an AP_UPD with this many payload words, zeroed - | MKAP Int{-ptr to AP_UPD is this far down stack-} Int{-# words-} - | UNPACK Int -- unpack N ptr words from t.o.s Constr - | UPK_TAG Int Int Int - -- unpack N non-ptr words from offset M in constructor - -- K words down the stack + | ALLOC_AP Int -- make an AP with this many payload words + | ALLOC_PAP Int Int -- make a PAP with this arity / payload words + | MKAP Int{-ptr to AP is this far down stack-} Int{-# words-} + | MKPAP Int{-ptr to PAP is this far down stack-} Int{-# words-} + | UNPACK Int -- unpack N words from t.o.s Constr | PACK DataCon Int -- after assembly, the DataCon is an index into the -- itbl array @@ -100,18 +114,26 @@ data BCInstr | JMP LocalLabel -- For doing calls to C (via glue code generated by ByteCodeFFI) - | CCALL Addr -- of the glue code + | CCALL Int -- stack frame size + (Ptr ()) -- addr of the glue code + + -- For doing magic ByteArray passing to foreign calls + | SWIZZLE Int -- to the ptr N words down the stack, + Int -- add M (interpreted as a signed 16-bit entity) -- To Infinity And Beyond | ENTER - | RETURN PrimRep - -- unboxed value on TOS. Use tag to find underlying ret itbl - -- and return as per that. + | RETURN -- return a lifted value + | RETURN_UBX CgRep -- return an unlifted value, here's its rep +-- ----------------------------------------------------------------------------- +-- Printing bytecode instructions instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs origin malloced) - = (text "ProtoBCO" <+> ppr name <+> text (show malloced) <> colon) + ppr (ProtoBCO name instrs bitmap bsize arity origin malloced) + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <+> text (show malloced) <> colon) + $$ nest 6 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap)) $$ nest 6 (vcat (map ppr instrs)) $$ case origin of Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts) @@ -119,27 +141,36 @@ instance Outputable a => Outputable (ProtoBCO a) where instance Outputable BCInstr where ppr (STKCHECK n) = text "STKCHECK" <+> int n - ppr (ARGCHECK n) = text "ARGCHECK" <+> int n ppr (PUSH_L offset) = text "PUSH_L " <+> int offset ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2 ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3 - ppr (PUSH_G (Left nm)) = text "PUSH_G " <+> ppr nm - ppr (PUSH_G (Right op)) = text "PUSH_G " <+> text "PrelPrimopWrappers." + ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm + ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." <> ppr op - ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk + ppr (PUSH_BCO bco) = text "PUSH_BCO" <+> nest 3 (ppr bco) + ppr (PUSH_ALTS bco) = text "PUSH_ALTS " <+> ppr bco + ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (int nw) <+> text (show aa) + ppr PUSH_APPLY_N = text "PUSH_APPLY_N" + ppr PUSH_APPLY_V = text "PUSH_APPLY_V" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" - ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d - ppr (ALLOC sz) = text "ALLOC " <+> int sz + ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> int sz + ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> int arity <+> int sz ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words," <+> int offset <+> text "stkoff" ppr (UNPACK sz) = text "UNPACK " <+> int sz - ppr (UPK_TAG n m k) = text "UPK_TAG " <+> int n <> text "words" - <+> int m <> text "conoff" - <+> int k <> text "stkoff" ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz ppr (LABEL lab) = text "__" <> int lab <> colon ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab @@ -153,44 +184,73 @@ instance Outputable BCInstr where ppr (JMP lab) = text "JMP" <+> int lab ppr CASEFAIL = text "CASEFAIL" ppr ENTER = text "ENTER" - ppr (RETURN pk) = text "RETURN " <+> ppr pk - ppr (CCALL marshall_addr) = text "CCALL " <+> text "marshall code at" + ppr RETURN = text "RETURN" + ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk + ppr (CCALL off marshall_addr) = text "CCALL " <+> int off + <+> text "marshall code at" <+> text (show marshall_addr) + ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> int stkoff + <+> text "by" <+> int n +-- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn. These _must_ be -- correct, or overestimates of reality, to be safe. + +-- NOTE: we aggregate the stack use from case alternatives too, so that +-- we can do a single stack check at the beginning of a function only. + +-- This could all be made more accurate by keeping track of a proper +-- stack high water mark, but it doesn't seem worth the hassle. + +protoBCOStackUse :: ProtoBCO a -> Int +protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) + bciStackUse :: BCInstr -> Int -bciStackUse (STKCHECK n) = 0 -bciStackUse (ARGCHECK n) = 0 -bciStackUse (PUSH_L offset) = 1 -bciStackUse (PUSH_LL o1 o2) = 2 -bciStackUse (PUSH_LLL o1 o2 o3) = 3 -bciStackUse (PUSH_G globalish) = 1 -bciStackUse (PUSH_AS nm pk) = 2 -bciStackUse (PUSH_UBX lit nw) = nw -bciStackUse (PUSH_TAG n) = 1 -bciStackUse (ALLOC sz) = 1 +bciStackUse STKCHECK{} = 0 +bciStackUse PUSH_L{} = 1 +bciStackUse PUSH_LL{} = 2 +bciStackUse PUSH_LLL{} = 3 +bciStackUse PUSH_G{} = 1 +bciStackUse PUSH_PRIMOP{} = 1 +bciStackUse PUSH_BCO{} = 1 +bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco +bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco +bciStackUse (PUSH_UBX _ nw) = nw +bciStackUse PUSH_APPLY_N{} = 1 +bciStackUse PUSH_APPLY_V{} = 1 +bciStackUse PUSH_APPLY_F{} = 1 +bciStackUse PUSH_APPLY_D{} = 1 +bciStackUse PUSH_APPLY_L{} = 1 +bciStackUse PUSH_APPLY_P{} = 1 +bciStackUse PUSH_APPLY_PP{} = 1 +bciStackUse PUSH_APPLY_PPP{} = 1 +bciStackUse PUSH_APPLY_PPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPPP{} = 1 +bciStackUse ALLOC_AP{} = 1 +bciStackUse ALLOC_PAP{} = 1 bciStackUse (UNPACK sz) = sz -bciStackUse (UPK_TAG n m k) = n + 1{-tag-} -bciStackUse (LABEL lab) = 0 -bciStackUse (TESTLT_I i lab) = 0 -bciStackUse (TESTEQ_I i lab) = 0 -bciStackUse (TESTLT_F f lab) = 0 -bciStackUse (TESTEQ_F f lab) = 0 -bciStackUse (TESTLT_D d lab) = 0 -bciStackUse (TESTEQ_D d lab) = 0 -bciStackUse (TESTLT_P i lab) = 0 -bciStackUse (TESTEQ_P i lab) = 0 -bciStackUse CASEFAIL = 0 -bciStackUse (JMP lab) = 0 -bciStackUse ENTER = 0 -bciStackUse (RETURN pk) = 0 -bciStackUse (CCALL marshall_addr) = 0 +bciStackUse LABEL{} = 0 +bciStackUse TESTLT_I{} = 0 +bciStackUse TESTEQ_I{} = 0 +bciStackUse TESTLT_F{} = 0 +bciStackUse TESTEQ_F{} = 0 +bciStackUse TESTLT_D{} = 0 +bciStackUse TESTEQ_D{} = 0 +bciStackUse TESTLT_P{} = 0 +bciStackUse TESTEQ_P{} = 0 +bciStackUse CASEFAIL{} = 0 +bciStackUse JMP{} = 0 +bciStackUse ENTER{} = 0 +bciStackUse RETURN{} = 0 +bciStackUse RETURN_UBX{} = 1 +bciStackUse CCALL{} = 0 +bciStackUse SWIZZLE{} = 0 -- These insns actually reduce stack use, but we need the high-tide level, -- so can't use this info. Not that it matters much. -bciStackUse (SLIDE n d) = 0 -bciStackUse (MKAP offset sz) = 0 -bciStackUse (PACK dcon sz) = 1 -- worst case is PACK 0 words - +bciStackUse SLIDE{} = 0 +bciStackUse MKAP{} = 0 +bciStackUse MKPAP{} = 0 +bciStackUse PACK{} = 1 -- worst case is PACK 0 words \end{code}