From 7b4c425051ce7fb1a1185e864a769d8f21353009 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 19 Dec 2000 10:36:10 +0000 Subject: [PATCH] [project @ 2000-12-19 10:36:10 by sewardj] Abstractify the concept 'sized sequence of elements' and other cleanups --- ghc/compiler/ghci/ByteCodeGen.lhs | 296 +++++++++++++++---------------------- 1 file changed, 121 insertions(+), 175 deletions(-) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index a8c1f43..73046e4 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -13,8 +13,8 @@ module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, #include "HsVersions.h" import Outputable -import Name ( Name, getName, nameModule ) -import Id ( Id, idType, isDataConId_maybe ) +import Name ( Name, getName, nameModule, mkSysLocalName ) +import Id ( Id, idType, isDataConId_maybe, mkVanillaId ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) import FiniteMap ( FiniteMap, addListToFM, listToFM, filterFM, @@ -38,12 +38,12 @@ import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) import ClosureInfo ( mkVirtHeapOffsets ) import Module ( ModuleName, moduleName ) +import Unique ( mkPseudoUnique3 ) import List ( intersperse ) import Monad ( foldM ) import ST ( runST ) -import MArray ( MArray(..), IOArray, IOUArray, HasBounds(..), freeze, - mapArray, castSTUArray, +import MArray ( castSTUArray, newFloatArray, writeFloatArray, newDoubleArray, writeDoubleArray, newIntArray, writeIntArray, @@ -54,7 +54,7 @@ import Addr ( Word, Addr, addrToInt, nullAddr ) import Bits ( Bits(..), shiftR ) import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array# ) -import IOExts ( IORef, readIORef, writeIORef, fixIO ) +import IOExts ( IORef, fixIO ) import ArrayBase import PrelArr ( Array(..) ) import PrelIOBase ( IO(..) ) @@ -100,14 +100,18 @@ coreExprToBCOs :: DynFlags -> IO UnlinkedBCOExpr coreExprToBCOs dflags expr = do showPass dflags "ByteCodeGen" - let invented_id = panic "invented_id" :: Id - (BcM_State all_proto_bcos final_ctr) + + -- create a totally bogus name for the top-level BCO; this + -- should be harmless, since it's never used for anything + let invented_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level") + let invented_id = mkVanillaId invented_name (panic "invented_id's type") + + let (BcM_State all_proto_bcos final_ctr) = runBc (BcM_State [] 0) (schemeR (invented_id, freeVars expr)) - dumpIfSet_dyn dflags Opt_D_dump_InterpSyn + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos))) - let invented_name = getName invented_id let root_proto_bco = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of [root_bco] -> root_bco @@ -121,27 +125,26 @@ coreExprToBCOs dflags expr - data UnlinkedBCO = UnlinkedBCO Name - Int (IOUArray Int Word16) -- insns - Int (IOUArray Int Word) -- literals - Int (IOArray Int Name) -- ptrs - Int (IOArray Int Name) -- itbl refs + (SizedSeq Word16) -- insns + (SizedSeq Word) -- literals + (SizedSeq Name) -- ptrs + (SizedSeq Name) -- itbl refs -nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _ _ _ _ _) = nm +nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm -- When translating expressions, we need to distinguish the root -- BCO for the expression type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO]) instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm n_insns insns n_lits lits n_ptrs ptrs n_itbls itbls) + ppr (UnlinkedBCO nm insns lits ptrs itbls) = sep [text "BCO", ppr nm, text "with", - int n_insns, text "insns", - int n_lits, text "lits", - int n_ptrs, text "ptrs", - int n_itbls, text "itbls"] + int (sizeSS insns), text "insns", + int (sizeSS lits), text "lits", + int (sizeSS ptrs), text "ptrs", + int (sizeSS itbls), text "itbls"] -- these need a proper home @@ -165,8 +168,6 @@ filterNameMap mods env type LocalLabel = Int -data UnboxedLit = UnboxedI Int | UnboxedF Float | UnboxedD Double - data BCInstr -- Messing with the stack = ARGCHECK Int @@ -182,7 +183,7 @@ data BCInstr -- Pushing literals | PUSH_UBX Literal Int -- push this int/float/double, NO TAG, on the stack - -- Int is # of items in literal pool to push + -- Int is # of words to copy from literal pool | PUSH_TAG Int -- push this tag on the stack | SLIDE Int{-this many-} Int{-down by this much-} @@ -220,10 +221,15 @@ instance Outputable BCInstr where ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm 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_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 (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz 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 @@ -238,10 +244,6 @@ instance Outputable BCInstr where ppr ENTER = text "ENTER" ppr RETURN = text "RETURN" -pprAltCode discrs_n_codes - = vcat (map f discrs_n_codes) - where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code)) - instance Outputable a => Outputable (ProtoBCO a) where ppr (ProtoBCO name instrs origin) = (text "ProtoBCO" <+> ppr name <> colon) @@ -724,12 +726,12 @@ instance Outputable Discr where -- Find things in the BCEnv (the what's-on-the-stack-env) -- See comment preceding pushAtom for precise meaning of env contents -lookupBCEnv :: BCEnv -> Id -> Int -lookupBCEnv env nm - = case lookupFM env nm of - Nothing -> pprPanic "lookupBCEnv" - (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env))) - Just xx -> xx +--lookupBCEnv :: BCEnv -> Id -> Int +--lookupBCEnv env nm +-- = case lookupFM env nm of +-- Nothing -> pprPanic "lookupBCEnv" +-- (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env))) +-- Just xx -> xx lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int lookupBCEnv_maybe = lookupFM @@ -768,9 +770,6 @@ data BcM_State type BcM result = BcM_State -> (result, BcM_State) -mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State -mkBcM_State = BcM_State - runBc :: BcM_State -> BcM () -> BcM_State runBc init_st m = case m init_st of { (r,st) -> st } @@ -834,36 +833,28 @@ assembleBCO (ProtoBCO nm instrs origin) = case lookupFM label_env lab of Just bco_offset -> bco_offset Nothing -> pprPanic "assembleBCO.findLabel" (int lab) - - init_n_insns = 10 - init_n_lits = 4 - init_n_ptrs = 4 - init_n_itbls = 4 in - do insns <- newXIOUArray init_n_insns :: IO (XIOUArray Word16) - lits <- newXIOUArray init_n_lits :: IO (XIOUArray Word) - ptrs <- newXIOArray init_n_ptrs -- :: IO (XIOArray Name) - itbls <- newXIOArray init_n_itbls -- :: IO (XIOArray Name) - - -- pass 2: generate the instruction, ptr and nonptr bits + do -- pass 2: generate the instruction, ptr and nonptr bits + insns <- return emptySS :: IO (SizedSeq Word16) + lits <- return emptySS :: IO (SizedSeq Word) + ptrs <- return emptySS :: IO (SizedSeq Name) + itbls <- return emptySS :: IO (SizedSeq Name) let init_asm_state = (insns,lits,ptrs,itbls) - final_asm_state <- mkBits findLabel init_asm_state instrs - - -- unwrap the expandable arrays - let final_insns = stuffXIOU insns - final_lits = stuffXIOU lits - final_ptrs = stuffXIO ptrs - final_itbls = stuffXIO itbls - - return (UnlinkedBCO nm - (usedXIOU insns) final_insns - (usedXIOU lits) final_lits - (usedXIO ptrs) final_ptrs - (usedXIO itbls) final_itbls) + (final_insns, final_lits, final_ptrs, final_itbls) + <- mkBits findLabel init_asm_state instrs + return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls) -- instrs nonptrs ptrs itbls -type AsmState = (XIOUArray Word16, XIOUArray Word, XIOArray Name, XIOArray Name) +type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name) + +data SizedSeq a = SizedSeq !Int [a] +emptySS = SizedSeq 0 [] +addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs)) +addListToSS (SizedSeq n r_xs) xs + = return (SizedSeq (n + length xs) (reverse xs ++ r_xs)) +sizeSS (SizedSeq n r_xs) = n +listFromSS (SizedSeq n r_xs) = return (reverse r_xs) -- This is where all the action is (pass 2 of the assembler) @@ -887,8 +878,8 @@ mkBits findLabel st proto_insns PUSH_AS nm pk -> do (p, st2) <- ptr st nm (np, st3) <- ret_itbl st2 pk instr3 st3 i_PUSH_AS p np - PUSH_UBX lit nw32s -> do (np, st2) <- literal st lit - instr3 st2 i_PUSH_UBX np nw32s + PUSH_UBX lit nws -> do (np, st2) <- literal st lit + instr3 st2 i_PUSH_UBX np nws PUSH_TAG tag -> instr2 st i_PUSH_TAG tag SLIDE n by -> instr3 st i_SLIDE n by ALLOC n -> instr2 st i_ALLOC n @@ -922,54 +913,54 @@ mkBits findLabel st proto_insns i2s = fromIntegral instr1 (st_i0,st_l0,st_p0,st_I0) i1 - = do st_i1 <- addToXIOUArray st_i0 (i2s i1) + = do st_i1 <- addToSS st_i0 (i2s i1) return (st_i1,st_l0,st_p0,st_I0) instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2 - = do st_i1 <- addToXIOUArray st_i0 (i2s i1) - st_i2 <- addToXIOUArray st_i1 (i2s i2) + = do st_i1 <- addToSS st_i0 (i2s i1) + st_i2 <- addToSS st_i1 (i2s i2) return (st_i2,st_l0,st_p0,st_I0) instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 - = do st_i1 <- addToXIOUArray st_i0 (i2s i1) - st_i2 <- addToXIOUArray st_i1 (i2s i2) - st_i3 <- addToXIOUArray st_i2 (i2s i3) + = do st_i1 <- addToSS st_i0 (i2s i1) + st_i2 <- addToSS st_i1 (i2s i2) + st_i3 <- addToSS st_i2 (i2s i3) return (st_i3,st_l0,st_p0,st_I0) instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4 - = do st_i1 <- addToXIOUArray st_i0 (i2s i1) - st_i2 <- addToXIOUArray st_i1 (i2s i2) - st_i3 <- addToXIOUArray st_i2 (i2s i3) - st_i4 <- addToXIOUArray st_i3 (i2s i4) + = do st_i1 <- addToSS st_i0 (i2s i1) + st_i2 <- addToSS st_i1 (i2s i2) + st_i3 <- addToSS st_i2 (i2s i3) + st_i4 <- addToSS st_i3 (i2s i4) return (st_i4,st_l0,st_p0,st_I0) float (st_i0,st_l0,st_p0,st_I0) f - = do let w32s = mkLitF f - st_l1 <- addListToXIOUArray st_l0 w32s - return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0)) + = do let ws = mkLitF f + st_l1 <- addListToSS st_l0 ws + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) double (st_i0,st_l0,st_p0,st_I0) d - = do let w32s = mkLitD d - st_l1 <- addListToXIOUArray st_l0 w32s - return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0)) + = do let ws = mkLitD d + st_l1 <- addListToSS st_l0 ws + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) int (st_i0,st_l0,st_p0,st_I0) i - = do let w32s = mkLitI i - st_l1 <- addListToXIOUArray st_l0 w32s - return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0)) + = do let ws = mkLitI i + st_l1 <- addListToSS st_l0 ws + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) addr (st_i0,st_l0,st_p0,st_I0) a - = do let w32s = mkLitA a - st_l1 <- addListToXIOUArray st_l0 w32s - return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0)) + = do let ws = mkLitA a + st_l1 <- addListToSS st_l0 ws + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) ptr (st_i0,st_l0,st_p0,st_I0) p - = do st_p1 <- addToXIOArray st_p0 p - return (usedXIO st_p0, (st_i0,st_l0,st_p1,st_I0)) + = do st_p1 <- addToSS st_p0 p + return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0)) itbl (st_i0,st_l0,st_p0,st_I0) dcon - = do st_I1 <- addToXIOArray st_I0 (getName dcon) - return (usedXIO st_I0, (st_i0,st_l0,st_p0,st_I1)) + = do st_I1 <- addToSS st_I0 (getName dcon) + return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1)) literal st (MachInt j) = int st (fromIntegral j) literal st (MachFloat r) = float st (fromRational r) @@ -1000,10 +991,14 @@ instrSizeB instr PUSH_LL _ _ -> 6 PUSH_LLL _ _ _ -> 8 PUSH_G _ -> 4 + PUSH_AS _ _ -> 6 + PUSH_UBX _ _ -> 6 + PUSH_TAG _ -> 4 SLIDE _ _ -> 6 ALLOC _ -> 4 MKAP _ _ -> 6 UNPACK _ -> 4 + UPK_TAG _ _ _ -> 8 PACK _ _ -> 6 LABEL _ -> 4 TESTLT_I _ _ -> 6 @@ -1073,67 +1068,6 @@ mkLitA a return [w0] ) - --- Zero-based expandable arrays -data XIOUArray ele - = XIOUArray { usedXIOU :: Int, stuffXIOU :: (IOUArray Int ele) } -data XIOArray ele - = XIOArray { usedXIO :: Int , stuffXIO :: (IOArray Int ele) } - -newXIOUArray size - = do arr <- newArray (0, size-1) - return (XIOUArray 0 arr) - -addListToXIOUArray xarr [] - = return xarr -addListToXIOUArray xarr (x:xs) - = addToXIOUArray xarr x >>= \ xarr' -> addListToXIOUArray xarr' xs - - -addToXIOUArray :: MArray IOUArray a IO - => XIOUArray a -> a -> IO (XIOUArray a) -addToXIOUArray (XIOUArray n_arr arr) x - = case bounds arr of - (lo, hi) -> ASSERT(lo == 0) - if n_arr > hi - then do new_arr <- newArray (0, 2*hi-1) - copy hi arr new_arr - addToXIOUArray (XIOUArray n_arr new_arr) x - else do writeArray arr n_arr x - return (XIOUArray (n_arr+1) arr) - where - copy :: MArray IOUArray a IO - => Int -> IOUArray Int a -> IOUArray Int a -> IO () - copy n src dst - | n < 0 = return () - | otherwise = do nx <- readArray src n - writeArray dst n nx - copy (n-1) src dst - - - -newXIOArray size - = do arr <- newArray (0, size-1) - return (XIOArray 0 arr) - -addToXIOArray :: XIOArray a -> a -> IO (XIOArray a) -addToXIOArray (XIOArray n_arr arr) x - = case bounds arr of - (lo, hi) -> ASSERT(lo == 0) - if n_arr > hi - then do new_arr <- newArray (0, 2*hi-1) - copy hi arr new_arr - addToXIOArray (XIOArray n_arr new_arr) x - else do writeArray arr n_arr x - return (XIOArray (n_arr+1) arr) - where - copy :: Int -> IOArray Int a -> IOArray Int a -> IO () - copy n src dst - | n < 0 = return () - | otherwise = do nx <- readArray src n - writeArray dst n nx - copy (n-1) src dst - \end{code} %************************************************************************ @@ -1157,19 +1091,15 @@ data BCO# = BCO# ByteArray# -- instrs :: array Word16# ByteArray# -- itbls :: Array Addr# -} -data LinkedBCO = LinkedBCO BCO# - - - GLOBAL_VAR(v_cafTable, [], [HValue]) -addCAF :: HValue -> IO () -addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs) +--addCAF :: HValue -> IO () +--addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs) -bcosToHValue :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr -> IO HValue -bcosToHValue ie ce (root_bco, other_bcos) - = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos) - return linked_expr +--bcosToHValue :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr -> IO HValue +--bcosToHValue ie ce (root_bco, other_bcos) +-- = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos) +-- return linked_expr linkIModules :: ItblEnv -- incoming global itbl env; returned updated @@ -1211,32 +1141,49 @@ linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO] -> IO [HValue] -- IO [BCO#] really linkBCOs ie ce binds = mapM (linkBCO ie ce) binds -linkBCO ie ce (UnlinkedBCO nm - n_insns insns n_literals literals - n_ptrs ptrs n_itbls itbls) - = do linked_ptrs <- mapArray (lookupCE ce) ptrs - linked_itbls <- mapArray (lookupIE ie) itbls +linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) + = do insns <- listFromSS insnsSS + literals <- listFromSS literalsSS + ptrs <- listFromSS ptrsSS + itbls <- listFromSS itblsSS + + let linked_ptrs = map (lookupCE ce) ptrs + linked_itbls = map (lookupIE ie) itbls + + let n_insns = sizeSS insnsSS + n_literals = sizeSS literalsSS + n_ptrs = sizeSS ptrsSS + n_itbls = sizeSS itblsSS - ptrs_froz <- freeze linked_ptrs - let ptrs_parr = case ptrs_froz of Array lo hi parr -> parr + let ptrs_arr = array (0, n_ptrs-1) (indexify linked_ptrs) + :: Array Int HValue + ptrs_parr = case ptrs_arr of Array lo hi parr -> parr - insns_froz <- freeze insns - let insns_barr = case insns_froz of UArray lo hi barr -> barr + itbls_arr = array (0, n_itbls-1) (indexify linked_itbls) + :: UArray Int Addr + itbls_barr = case itbls_arr of UArray lo hi barr -> barr - literals_froz <- freeze literals - let literals_barr = case literals_froz of UArray lo hi barr -> barr + insns_arr = array (0, n_insns-1) (indexify insns) + :: UArray Int Word16 + insns_barr = case insns_arr of UArray lo hi barr -> barr - itbls_froz <- freeze linked_itbls - let itbls_barr = case itbls_froz of UArray lo hi barr -> barr + literals_arr = array (0, n_literals-1) (indexify literals) + :: UArray Int Word + literals_barr = case literals_arr of UArray lo hi barr -> barr + + indexify :: [a] -> [(Int, a)] + indexify xs = zip [0..] xs BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr return (unsafeCoerce# bco#) + data BCO = BCO BCO# newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO -newBCO a b c d = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) +newBCO a b c d + = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) lookupCE :: ClosureEnv -> Name -> HValue @@ -1428,7 +1375,6 @@ foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr -data Constructor = Constructor Int{-ptrs-} Int{-nptrs-} -- Ultra-minimalist version specially for constructors -- 1.7.10.4