X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeInstr.lhs;h=58e8eda8d5841192d934ccb5375e3163ec7d2252;hb=2cc5b907318f97e19b28b2ad8ed9ff8c1f401dcc;hp=e90393924c5157ef1865e107460f7c375b8534ad;hpb=3a8cc90c45bea721ff9aceba4b4954bd42662ac8;p=ghc-hetmet.git

diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs
index e903939..58e8eda 100644
--- a/ghc/compiler/ghci/ByteCodeInstr.lhs
+++ b/ghc/compiler/ghci/ByteCodeInstr.lhs
@@ -19,7 +19,7 @@ import PrimRep		( PrimRep )
 import DataCon		( DataCon )
 import VarSet		( VarSet )
 import PrimOp		( PrimOp )
-
+import Ptr
 \end{code}
 
 %************************************************************************
@@ -36,8 +36,9 @@ data ProtoBCO a
 					-- what the BCO came from
               (Either [AnnAlt Id VarSet]
                       (AnnExpr Id VarSet))
+              [Ptr ()]			-- malloc'd; free when BCO is GCd
 
-nameOfProtoBCO (ProtoBCO nm insns origin) = nm
+nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm
 
 type LocalLabel = Int
 
@@ -55,9 +56,17 @@ data BCInstr
    | PUSH_AS   Name PrimRep	-- push alts and BCO_ptr_ret_info
 				-- PrimRep so we know which itbl
    -- Pushing literals
-   | PUSH_UBX  Literal	Int 
-                        -- push this int/float/double, NO TAG, on the stack
+   | PUSH_UBX  (Either Literal (Ptr ()))
+               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
 
    | SLIDE     Int{-this many-} Int{-down by this much-}
@@ -87,16 +96,23 @@ data BCInstr
    | TESTEQ_P  Int    LocalLabel
 
    | CASEFAIL
+   | JMP              LocalLabel
+
+   -- For doing calls to C (via glue code generated by ByteCodeFFI)
+   | CCALL            (Ptr ())	-- of the glue code
+   | SWIZZLE          Int Int	-- to the ptr N words down the stack,
+				-- 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    PrimRep
+               -- unboxed value on TOS.  Use tag to find underlying ret itbl
+               -- and return as per that.
 
 
 instance Outputable a => Outputable (ProtoBCO a) where
-   ppr (ProtoBCO name instrs origin)
-      = (text "ProtoBCO" <+> ppr name <> colon)
+   ppr (ProtoBCO name instrs origin malloced)
+      = (text "ProtoBCO" <+> ppr name <+> text (show malloced) <> colon)
         $$ nest 6 (vcat (map ppr instrs))
         $$ case origin of
               Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
@@ -112,7 +128,10 @@ instance Outputable BCInstr where
    ppr (PUSH_G (Right op))   = text "PUSH_G  " <+> text "PrelPrimopWrappers." 
                                                <> ppr op
    ppr (PUSH_AS nm pk)       = text "PUSH_AS " <+> ppr nm <+> ppr pk
-   ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
+
+   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_TAG n)          = text "PUSH_TAG" <+> int n
    ppr (SLIDE n d)           = text "SLIDE   " <+> int n <+> int d
    ppr (ALLOC sz)            = text "ALLOC   " <+> int sz
@@ -132,10 +151,14 @@ instance Outputable BCInstr where
    ppr (TESTEQ_D  d lab)     = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
    ppr (TESTLT_P  i lab)     = text "TESTLT_P" <+> int i <+> text "__" <> int lab
    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
+   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" 
+                                               <+> 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.
@@ -162,8 +185,11 @@ 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 (SWIZZLE stkoff n)    = 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.