From: sewardj Date: Tue, 19 Dec 2000 12:36:12 +0000 (+0000) Subject: [project @ 2000-12-19 12:36:12 by sewardj] X-Git-Tag: Approximately_9120_patches~3061 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=026b7e0c913c10b231eafa56d5dc8ac88145a48a;p=ghc-hetmet.git [project @ 2000-12-19 12:36:12 by sewardj] Start to get the bytecode assembler working --- diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 73046e4..e1f45cf 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -13,7 +13,9 @@ module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, #include "HsVersions.h" import Outputable -import Name ( Name, getName, nameModule, mkSysLocalName ) +import Name ( Name, getName, nameModule, mkSysLocalName, toRdrName ) +import RdrName ( rdrNameOcc, rdrNameModule ) +import OccName ( occNameString ) import Id ( Id, idType, isDataConId_maybe, mkVanillaId ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) @@ -37,8 +39,9 @@ import Constants ( wORD_SIZE ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) import ClosureInfo ( mkVirtHeapOffsets ) -import Module ( ModuleName, moduleName ) +import Module ( ModuleName, moduleName, moduleNameFS ) import Unique ( mkPseudoUnique3 ) +import Linker ( lookupSymbol ) import List ( intersperse ) import Monad ( foldM ) @@ -124,6 +127,42 @@ coreExprToBCOs dflags expr return (root_bco, auxiliary_bcos) +-- Linking stuff +linkIModules :: ItblEnv -- incoming global itbl env; returned updated + -> ClosureEnv -- incoming global closure env; returned updated + -> [([UnlinkedBCO], ItblEnv)] + -> IO ([HValue], ItblEnv, ClosureEnv) +linkIModules gie gce mods = do + let (bcoss, ies) = unzip mods + bcos = concat bcoss + top_level_binders = map nameOfUnlinkedBCO bcos + final_gie = foldr plusFM gie ies + + (new_bcos, new_gce) <- + fixIO (\ ~(new_bcos, new_gce) -> do + new_bcos <- linkBCOs final_gie new_gce bcos + let new_gce = addListToFM gce (zip top_level_binders new_bcos) + return (new_bcos, new_gce)) + + return (new_bcos, final_gie, new_gce) + + +linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr + -> IO HValue -- IO BCO# really +linkIExpr ie ce (root_ul_bco, aux_ul_bcos) + = do let aux_ul_binders = map nameOfUnlinkedBCO aux_ul_bcos + (aux_bcos, aux_ce) + <- fixIO + (\ ~(aux_bcos, new_ce) + -> do new_bcos <- linkBCOs ie new_ce aux_ul_bcos + let new_ce = addListToFM ce (zip aux_ul_binders new_bcos) + return (new_bcos, new_ce) + ) + [root_bco] + <- linkBCOs ie aux_ce [root_ul_bco] + return root_bco + + data UnlinkedBCO = UnlinkedBCO Name @@ -1079,12 +1118,6 @@ mkLitA a \begin{code} {- -data UnlinkedBCO - = UnlinkedBCO Int (IOUArray Int Word16) -- #insns insns - Int (IOUArray Int Word32) -- #literals literals - Int (IOArray Int Name) -- #ptrs ptrs - Int (IOArray Int Name) -- #itblrefs itblrefs - data BCO# = BCO# ByteArray# -- instrs :: array Word16# ByteArray# -- literals :: array Word32# PtrArray# -- ptrs :: Array HValue @@ -1102,41 +1135,6 @@ GLOBAL_VAR(v_cafTable, [], [HValue]) -- return linked_expr -linkIModules :: ItblEnv -- incoming global itbl env; returned updated - -> ClosureEnv -- incoming global closure env; returned updated - -> [([UnlinkedBCO], ItblEnv)] - -> IO ([HValue], ItblEnv, ClosureEnv) -linkIModules gie gce mods = do - let (bcoss, ies) = unzip mods - bcos = concat bcoss - top_level_binders = map nameOfUnlinkedBCO bcos - final_gie = foldr plusFM gie ies - - (new_bcos, new_gce) <- - fixIO (\ ~(new_bcos, new_gce) -> do - new_bcos <- linkBCOs final_gie new_gce bcos - let new_gce = addListToFM gce (zip top_level_binders new_bcos) - return (new_bcos, new_gce)) - - return (new_bcos, final_gie, new_gce) - - -linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr - -> IO HValue -- IO BCO# really -linkIExpr ie ce (root_ul_bco, aux_ul_bcos) - = do let aux_ul_binders = map nameOfUnlinkedBCO aux_ul_bcos - (aux_bcos, aux_ce) - <- fixIO - (\ ~(aux_bcos, new_ce) - -> do new_bcos <- linkBCOs ie new_ce aux_ul_bcos - let new_ce = addListToFM ce (zip aux_ul_binders new_bcos) - return (new_bcos, new_ce) - ) - [root_bco] - <- linkBCOs ie aux_ce [root_ul_bco] - return root_bco - - linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO] -> IO [HValue] -- IO [BCO#] really linkBCOs ie ce binds = mapM (linkBCO ie ce) binds @@ -1148,7 +1146,7 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) itbls <- listFromSS itblsSS let linked_ptrs = map (lookupCE ce) ptrs - linked_itbls = map (lookupIE ie) itbls + linked_itbls <- mapM (lookupIE ie) itbls let n_insns = sizeSS insnsSS n_literals = sizeSS literalsSS @@ -1175,7 +1173,7 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) indexify xs = zip [0..] xs BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr - + return (unsafeCoerce# bco#) @@ -1192,12 +1190,23 @@ lookupCE ce nm Just aa -> unsafeCoerce# aa Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm) -lookupIE :: ItblEnv -> Name -> Addr -lookupIE ie nm - = case lookupFM ie nm of - Just (Ptr a) -> a - Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr nm) +lookupIE :: ItblEnv -> Name -> IO Addr +lookupIE ie con_nm + = case lookupFM ie con_nm of + Just (Ptr a) -> return a + Nothing + -> do -- try looking up in the object files. + m <- lookupSymbol (nameToCLabel con_nm "con_info") + case m of + Just addr -> return addr + Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr con_nm) +-- HACK!!! ToDo: cleaner +nameToCLabel :: Name -> String{-suffix-} -> String +nameToCLabel n suffix + = _UNPK_(moduleNameFS (rdrNameModule rn)) + ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix + where rn = toRdrName n {- @@ -1246,13 +1255,6 @@ lookupVar ce f v = Nothing -> return (f v) Just e -> return (Native e) ) - --- HACK!!! ToDo: cleaner -nameToCLabel :: Name -> String{-suffix-} -> String -nameToCLabel n suffix = - _UNPK_(moduleNameFS (rdrNameModule rn)) - ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix - where rn = toRdrName n -} \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index c0fb3cf..5d2338c 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -243,7 +243,6 @@ data DynFlag | Opt_D_dump_rn_stats | Opt_D_dump_stix | Opt_D_dump_simpl_stats - | Opt_D_dump_InterpSyn | Opt_D_dump_BCOs | Opt_D_source_stats | Opt_D_verbose_core2core diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 5a9a364..a7dd3ce 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.35 2000/12/14 12:52:40 sewardj Exp $ +-- $Id: DriverFlags.hs,v 1.36 2000/12/19 12:36:12 sewardj Exp $ -- -- Driver flags -- @@ -403,7 +403,6 @@ dynamic_flags = [ , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) ) , ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) ) , ( "ddump-simpl-stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) ) - , ( "ddump-interpsyn", NoArg (setDynFlag Opt_D_dump_InterpSyn) ) , ( "ddump-bcos", NoArg (setDynFlag Opt_D_dump_BCOs) ) , ( "dsource-stats", NoArg (setDynFlag Opt_D_source_stats) ) , ( "dverbose-core2core", NoArg (setDynFlag Opt_D_verbose_core2core) ) diff --git a/ghc/compiler/main/Interpreter.hs b/ghc/compiler/main/Interpreter.hs index 2946871..d90ca29 100644 --- a/ghc/compiler/main/Interpreter.hs +++ b/ghc/compiler/main/Interpreter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Interpreter.hs,v 1.10 2000/12/18 15:18:11 simonmar Exp $ +-- $Id: Interpreter.hs,v 1.11 2000/12/19 12:36:12 sewardj Exp $ -- -- Interpreter subsystem wrapper -- @@ -51,8 +51,8 @@ data UnlinkedBCOExpr = UnlinkedBCOExpr instance Outputable UnlinkedBCO where ppr x = text "Can't output UnlinkedBCO" -byteCodeGen = error "stgBindsToInterpSyn" +byteCodeGen = error "byteCodeGen" loadObjs = error "loadObjs" -resolveObjs = error "loadObjs" +resolveObjs = error "resolveObjs" interactiveUI = error "interactiveUI" #endif