newAddrArray, writeAddrArray )
import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..),
malloc, castPtr, plusPtr )
-import Addr ( Word, Addr, addrToInt, nullAddr )
+import Addr ( Word, addrToInt, nullAddr )
import Bits ( Bits(..), shiftR )
-import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array# )
+import PrelAddr ( Addr(..) )
+import PrelGHC ( BCO#, newBCO#, unsafeCoerce#,
+ ByteArray#, Array#, addrToHValue# )
import IOExts ( IORef, fixIO )
import ArrayBase
import PrelArr ( Array(..) )
-> 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)
+linkIModules gie gce mods
+ = do let (bcoss, ies) = unzip mods
+ bcos = concat bcoss
+ final_gie = foldr plusFM gie ies
+ (final_gce, linked_bcos) <- linkSomeBCOs final_gie gce bcos
+ return (linked_bcos, final_gie, final_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]
+ = do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos
+ (_, [root_bco]) <- linkSomeBCOs ie aux_ce [root_ul_bco]
return root_bco
+-- Link a bunch of BCOs and return them + updated closure env.
+linkSomeBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
+ -> IO (ClosureEnv, [HValue])
+linkSomeBCOs ie ce_in ul_bcos
+ = do let nms = map nameOfUnlinkedBCO ul_bcos
+ hvals <- fixIO
+ ( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs)
+ in mapM (linkBCO ie ce_out) ul_bcos )
+ let ce_out = addListToFM ce_in (zip nms hvals)
+ return (ce_out, hvals)
+ where
+ -- A lazier zip, in which no demand is propagated to the second
+ -- list unless some demand is propagated to the snd of one of the
+ -- result list elems.
+ zipLazily [] ys = []
+ zipLazily (x:xs) ys = (x, head ys) : zipLazily xs (tail ys)
data UnlinkedBCO
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 (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"
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO nm instrs_ordlist origin
- = ProtoBCO nm (peep (fromOL instrs_ordlist)) origin
+ = ProtoBCO nm (id {-peep-} (fromOL instrs_ordlist)) origin
where
peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
= PUSH_LLL off1 (off2-1) (off3-2) : peep rest
-- variable to which this value was bound, so as to give the
-- resulting BCO a name.
schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
-schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs)
+schemeR (nm, rhs)
+{-
+ | trace (showSDoc (
+ (char ' '
+ $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
+ $$ pprCoreExpr (deAnnotate rhs)
+ $$ char ' '
+ ))) False
+ = undefined
+-}
+ | otherwise
+ = schemeR_wrk rhs nm (collect [] rhs)
+
collect xs (_, AnnLam x e)
= collect (if isTyVar x then xs else (x:xs)) e
szsw_args = map taggedIdSizeW all_args
szw_args = sum szsw_args
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
- argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
+ argcheck = {-if null args then nilOL else-} unitOL (ARGCHECK szw_args)
in
schemeE szw_args 0 p_init body `thenBc` \ body_code ->
emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
AnnRec xs_n_rhss -> unzip xs_n_rhss
n = length xs
fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
+
+ -- Sizes of tagged free vars, + 1 for the fn
sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
-- This p', d' defn is safe because all the items being pushed
MachInt i -> code IntRep
MachFloat r -> code FloatRep
MachDouble r -> code DoubleRep
+ MachChar c -> code CharRep
where
code rep
= let size_host_words = untaggedSizeW rep
literal st (MachInt j) = int st (fromIntegral j)
literal st (MachFloat r) = float st (fromRational r)
literal st (MachDouble r) = double st (fromRational r)
+ literal st (MachChar c) = int st c
ctoi_itbl st pk
= addr st ret_itbl_addr
-- = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos)
-- return linked_expr
-
-linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
- -> IO [HValue] -- IO [BCO#] really
-linkBCOs ie ce binds = mapM (linkBCO ie ce) binds
-
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_ptrs <- mapM (lookupCE ce) ptrs
linked_itbls <- mapM (lookupIE ie) itbls
let n_insns = sizeSS insnsSS
= IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
-lookupCE :: ClosureEnv -> Name -> HValue
+lookupCE :: ClosureEnv -> Name -> IO HValue
lookupCE ce nm
= case lookupFM ce nm of
- Just aa -> unsafeCoerce# aa
- Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
+ Just aa -> return aa
+ Nothing
+ -> do m <- lookupSymbol (nameToCLabel nm "closure")
+ case m of
+ Just (A# addr) -> case addrToHValue# addr of
+ (# hval #) -> return hval
+ Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
lookupIE :: ItblEnv -> Name -> IO Addr
lookupIE ie con_nm
projects / ghc-hetmet.git / commitdiff