X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fghci%2FByteCodeInstr.lhs;h=7a965a14baa7a2d55492eda5c18ef814db3922bf;hb=aa162076d849966c54159410422a84c95e00340e;hp=c654b2095e2baa6e06bb700441468b716652c435;hpb=7c98178cfcb609d7518be822e88f0c7a1ff803d3;p=ghc-hetmet.git

diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs
index c654b20..7a965a1 100644
--- a/ghc/compiler/ghci/ByteCodeInstr.lhs
+++ b/ghc/compiler/ghci/ByteCodeInstr.lhs
@@ -19,6 +19,7 @@ import PrimRep		( PrimRep )
 import DataCon		( DataCon )
 import VarSet		( VarSet )
 import PrimOp		( PrimOp )
+import Foreign		( Addr )
 
 \end{code}
 
@@ -36,8 +37,9 @@ data ProtoBCO a
 					-- 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) = nm
+nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm
 
 type LocalLabel = Int
 
@@ -55,9 +57,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 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
 
    | SLIDE     Int{-this many-} Int{-down by this much-}
@@ -89,16 +99,21 @@ data BCInstr
    | CASEFAIL
    | JMP              LocalLabel
 
+   -- For doing calls to C (via glue code generated by ByteCodeFFI)
+   | CCALL            Addr	-- 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)
@@ -114,7 +129,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
@@ -138,7 +156,10 @@ instance Outputable BCInstr where
    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.
@@ -168,6 +189,8 @@ 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.