ByteCodeGen.lhs 53.7 KB
Newer Older
1
2
3
4
5
6
%
% (c) The University of Glasgow 2000
%
\section[ByteCodeGen]{Generate bytecode from Core}

\begin{code}
7
8
9
10
11
module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
		     filterNameMap,
                     byteCodeGen, coreExprToBCOs, 
		     linkIModules, linkIExpr
		   ) where
12
13
14
15

#include "HsVersions.h"

import Outputable
16
17
18
import Name		( Name, getName, nameModule, mkSysLocalName, toRdrName )
import RdrName		( rdrNameOcc, rdrNameModule )
import OccName		( occNameString )
19
import Id		( Id, idType, isDataConId_maybe, mkVanillaId )
20
import OrdList		( OrdList, consOL, snocOL, appOL, unitOL, 
21
			  nilOL, toOL, concatOL, fromOL )
22
import FiniteMap	( FiniteMap, addListToFM, listToFM, filterFM,
23
			  addToFM, lookupFM, fmToList, emptyFM, plusFM )
24
import CoreSyn
25
import PprCore		( pprCoreExpr, pprCoreAlt )
26
27
28
29
import Literal		( Literal(..) )
import PrimRep		( PrimRep(..) )
import CoreFVs		( freeVars )
import Type		( typePrimRep )
30
31
32
33
import DataCon		( DataCon, dataConTag, fIRST_TAG, dataConTyCon, 
			  dataConRepArgTys )
import TyCon		( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Class		( Class, classTyCon )
34
import Util		( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, global )
35
import Var		( isTyVar )
36
import VarSet		( VarSet, varSetElems )
37
import PrimRep		( getPrimRepSize, isFollowableRep )
38
import Constants	( wORD_SIZE )
39
40
41
import CmdLineOpts	( DynFlags, DynFlag(..) )
import ErrUtils		( showPass, dumpIfSet_dyn )
import ClosureInfo	( mkVirtHeapOffsets )
42
import Module		( ModuleName, moduleName, moduleNameFS )
43
import Unique		( mkPseudoUnique3 )
44
import Linker		( lookupSymbol )
45

46
import List		( intersperse )
47
import Monad		( foldM )
48
import ST		( runST )
49
import MArray		( castSTUArray, 
50
51
52
53
			  newFloatArray, writeFloatArray,
			  newDoubleArray,  writeDoubleArray,
			  newIntArray, writeIntArray,
			  newAddrArray, writeAddrArray )
54
import Foreign		( Storable(..), Word8, Word16, Word32, Ptr(..), 
55
			  malloc, castPtr, plusPtr )
56
import Addr		( Word, Addr, addrToInt, nullAddr )
57
import Bits		( Bits(..), shiftR )
58
59

import PrelGHC		( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array# )
60
import IOExts		( IORef, fixIO )
61
62
63
import ArrayBase	
import PrelArr		( Array(..) )
import PrelIOBase	( IO(..) )
64

65
66
\end{code}

67
68
69
70
71
%************************************************************************
%*									*
\subsection{Functions visible from outside this module.}
%*									*
%************************************************************************
72
73

\begin{code}
74

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
byteCodeGen :: DynFlags
            -> [CoreBind] 
            -> [TyCon] -> [Class]
            -> IO ([UnlinkedBCO], ItblEnv)
byteCodeGen dflags binds local_tycons local_classes
   = do showPass dflags "ByteCodeGen"
        let tycs = local_tycons ++ map classTyCon local_classes
        itblenv <- mkITbls tycs

        let flatBinds = concatMap getBind binds
            getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
            getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
            final_state = runBc (BcM_State [] 0) 
                                (mapBc schemeR flatBinds `thenBc_` returnBc ())
            (BcM_State proto_bcos final_ctr) = final_state

        dumpIfSet_dyn dflags Opt_D_dump_BCOs
           "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))

        bcos <- mapM assembleBCO proto_bcos

        return (bcos, itblenv)
        
98

99
100
101
102
103
104
105
-- Returns: (the root BCO for this expression, 
--           a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
	       -> CoreExpr
               -> IO UnlinkedBCOExpr
coreExprToBCOs dflags expr
 = do showPass dflags "ByteCodeGen"
106
107
108
109
110
111
112

      -- 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) 
113
114
             = runBc (BcM_State [] 0) 
                     (schemeR (invented_id, freeVars expr))
115
      dumpIfSet_dyn dflags Opt_D_dump_BCOs
116
117
118
119
120
121
122
123
124
125
126
127
128
129
         "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))

      let root_proto_bco 
             = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of
                  [root_bco] -> root_bco
          auxiliary_proto_bcos
             = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos

      auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos
      root_bco <- assembleBCO root_proto_bco

      return (root_bco, auxiliary_bcos)


130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
-- 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


166

167
168
data UnlinkedBCO
   = UnlinkedBCO Name
169
170
171
172
                 (SizedSeq Word16)	-- insns
                 (SizedSeq Word)	-- literals
                 (SizedSeq Name)	-- ptrs
                 (SizedSeq Name)	-- itbl refs
173

174
nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
175

176
177
178
179
180
-- When translating expressions, we need to distinguish the root
-- BCO for the expression
type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO])

instance Outputable UnlinkedBCO where
181
   ppr (UnlinkedBCO nm insns lits ptrs itbls)
182
      = sep [text "BCO", ppr nm, text "with", 
183
184
185
186
             int (sizeSS insns), text "insns",
             int (sizeSS lits), text "lits",
             int (sizeSS ptrs), text "ptrs",
             int (sizeSS itbls), text "itbls"]
187
188
189


-- these need a proper home
190
type ItblEnv    = FiniteMap Name (Ptr StgInfoTable)
191
type ClosureEnv = FiniteMap Name HValue
192
data HValue     = HValue  -- dummy type, actually a pointer to some Real Code.
193

194
195
196
197
-- remove all entries for a given set of modules from the environment
filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
filterNameMap mods env 
   = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
198
199
\end{code}

200
201
202
203
204
%************************************************************************
%*									*
\subsection{Bytecodes, and Outputery.}
%*									*
%************************************************************************
205
206

\begin{code}
207

208
209
type LocalLabel = Int

210
211
data BCInstr
   -- Messing with the stack
212
   = ARGCHECK  Int
213
   -- Push locals (existing bits of the stack)
214
   | PUSH_L    Int{-offset-}
215
216
   | PUSH_LL   Int Int{-2 offsets-}
   | PUSH_LLL  Int Int Int{-3 offsets-}
217
   -- Push a ptr
218
   | PUSH_G    Name
219
220
221
222
   -- Push an alt continuation
   | PUSH_AS   Name PrimRep	-- push alts and BCO_ptr_ret_info
				-- PrimRep so we know which itbl
   -- Pushing literals
223
224
   | PUSH_UBX  Literal	Int 
                        -- push this int/float/double, NO TAG, on the stack
225
			-- Int is # of words to copy from literal pool
226
   | PUSH_TAG  Int      -- push this tag on the stack
227

228
   | SLIDE     Int{-this many-} Int{-down by this much-}
229
   -- To do with the heap
230
231
   | ALLOC     Int	-- make an AP_UPD with this many payload words, zeroed
   | MKAP      Int{-ptr to AP_UPD is this far down stack-} Int{-# words-}
232
   | UNPACK    Int	-- unpack N ptr words from t.o.s Constr
233
234
235
   | UPK_TAG   Int Int Int
			-- unpack N non-ptr words from offset M in constructor
			-- K words down the stack
236
   | PACK      DataCon Int
237
238
			-- after assembly, the DataCon is an index into the
			-- itbl array
239
   -- For doing case trees
240
241
242
243
244
245
246
247
248
   | LABEL     LocalLabel
   | TESTLT_I  Int    LocalLabel
   | TESTEQ_I  Int    LocalLabel
   | TESTLT_F  Float  LocalLabel
   | TESTEQ_F  Float  LocalLabel
   | TESTLT_D  Double LocalLabel
   | TESTEQ_D  Double LocalLabel
   | TESTLT_P  Int    LocalLabel
   | TESTEQ_P  Int    LocalLabel
249
   | CASEFAIL
250
251
   -- To Infinity And Beyond
   | ENTER
252
253
254
   | RETURN	-- unboxed value on TOS.  Use tag to find underlying ret itbl
		-- and return as per that.

255

256
257
instance Outputable BCInstr where
   ppr (ARGCHECK n)          = text "ARGCHECK" <+> int n
258
   ppr (PUSH_L offset)       = text "PUSH_L  " <+> int offset
259
260
   ppr (PUSH_LL o1 o2)       = text "PUSH_LL " <+> int o1 <+> int o2
   ppr (PUSH_LLL o1 o2 o3)   = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
261
   ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
262
   ppr (PUSH_AS nm pk)       = text "PUSH_AS " <+> ppr nm <+> ppr pk
263
264
   ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
   ppr (PUSH_TAG n)          = text "PUSH_TAG" <+> int n
265
266
267
268
   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
269
270
271
   ppr (UPK_TAG n m k)       = text "UPK_TAG " <+> int n <> text "words" 
                                               <+> int m <> text "conoff"
                                               <+> int k <> text "stkoff"
272
   ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz
273
274
275
276
277
278
279
280
281
282
   ppr (LABEL     lab)       = text "__"       <> int lab <> colon
   ppr (TESTLT_I  i lab)     = text "TESTLT_I" <+> int i <+> text "__" <> int lab
   ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
   ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> int lab
   ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
   ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> int lab
   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 CASEFAIL              = text "CASEFAIL"
283
   ppr ENTER                 = text "ENTER"
284
   ppr RETURN                = text "RETURN"
285

286
instance Outputable a => Outputable (ProtoBCO a) where
287
   ppr (ProtoBCO name instrs origin)
288
      = (text "ProtoBCO" <+> ppr name <> colon)
289
        $$ nest 6 (vcat (map ppr instrs))
290
291
292
        $$ case origin of
              Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
              Right rhs -> pprCoreExpr (deAnnotate rhs)
293
\end{code}
294

295
296
297
298
299
%************************************************************************
%*									*
\subsection{Compilation schema for the bytecode generator.}
%*									*
%************************************************************************
300

301
302
303
304
\begin{code}

type BCInstrList = OrdList BCInstr

305
306
data ProtoBCO a 
   = ProtoBCO a 			-- name, in some sense
307
              [BCInstr] 		-- instrs
308
309
310
311
					-- what the BCO came from
              (Either [AnnAlt Id VarSet]
                      (AnnExpr Id VarSet))

312
313
nameOfProtoBCO (ProtoBCO nm insns origin) = nm

314
315
316
317
318
319
320
321

type Sequel = Int	-- back off to this depth before ENTER

-- Maps Ids to the offset from the stack _base_ so we don't have
-- to mess with it after each push/pop.
type BCEnv = FiniteMap Id Int	-- To find vars on the stack


322
323
324
325
326
327
328
329
330
331
332
333
334
335
-- 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
     where
        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
        peep (PUSH_L off1 : PUSH_L off2 : rest)
           = PUSH_LL off1 off2 : peep rest
        peep (i:rest)
           = i : peep rest
        peep []
           = []

336
337
338
339
340
341

-- Compile code for the right hand side of a let binding.
-- Park the resulting BCO in the monad.  Also requires the
-- variable to which this value was bound, so as to give the
-- resulting BCO a name.
schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
342
schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs)
343

344
345
346
347
collect xs (_, AnnLam x e) 
   = collect (if isTyVar x then xs else (x:xs)) e
collect xs not_lambda
   = (reverse xs, not_lambda)
348

349
350
351
schemeR_wrk original_body nm (args, body)
   = let fvs       = filter (not.isTyVar) (varSetElems (fst original_body))
         all_args  = fvs ++ reverse args
352
         szsw_args = map taggedIdSizeW all_args
353
         szw_args  = sum szsw_args
354
         p_init    = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
355
356
357
         argcheck  = if null args then nilOL else unitOL (ARGCHECK szw_args)
     in
     schemeE szw_args 0 p_init body 		`thenBc` \ body_code ->
358
     emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
359

360
361
362
363
364
365
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'.  Return the values which the stack environment
-- should map these items to.
mkStackOffsets :: Int -> [Int] -> [Int]
mkStackOffsets original_depth szsw
   = map (subtract 1) (tail (scanl (+) original_depth szsw))
366
367
368
369
370
371

-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList

-- Delegate tail-calls to schemeT.
372
373
374
schemeE d s p e@(fvs, AnnApp f a) 
   = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
schemeE d s p e@(fvs, AnnVar v)
375
   | isFollowableRep (typePrimRep (idType v))
376
   = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
377
378
379
380
381
382
383
384
385
386
387
388
   | otherwise
   = -- returning an unboxed value.  Heave it on the stack, SLIDE, and RETURN.
     let (push, szw) = pushAtom True d p (AnnVar v)
     in  returnBc (push 			-- value onto stack
                   `snocOL` SLIDE szw (d-s) 	-- clear to sequel
                   `snocOL` RETURN)		-- go

schemeE d s p (fvs, AnnLit literal)
   = let (push, szw) = pushAtom True d p (AnnLit literal)
     in  returnBc (push 			-- value onto stack
                   `snocOL` SLIDE szw (d-s) 	-- clear to sequel
                   `snocOL` RETURN)		-- go
389
390
391
392

schemeE d s p (fvs, AnnLet binds b)
   = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
                                   AnnRec xs_n_rhss -> unzip xs_n_rhss
393
394
         n     = length xs
         fvss  = map (filter (not.isTyVar).varSetElems.fst) rhss
395
         sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
396
397
398
399
400
401

         -- This p', d' defn is safe because all the items being pushed
         -- are ptrs, so all have size 1.  d' and p' reflect the stack
         -- after the closures have been allocated in the heap (but not
         -- filled in), and pointers to them parked on the stack.
         p'    = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
402
         d'    = d + n
403

404
405
406
407
408
         infos = zipE4 fvss sizes xs [n, n-1 .. 1]
         zipE  = zipEqual "schemeE"
         zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))

         -- ToDo: don't build thunks for things with no free variables
409
410
411
412
413
414
415
416
417
418
         buildThunk dd ([], size, id, off)
            = PUSH_G (getName id) 
              `consOL` unitOL (MKAP (off+size-1) size)
         buildThunk dd ((fv:fvs), size, id, off)
            = case pushAtom True dd p' (AnnVar fv) of
                 (push_code, pushed_szw)
                    -> push_code `appOL`
                       buildThunk (dd+pushed_szw) (fvs, size, id, off)

         thunkCode = concatOL (map (buildThunk d') infos)
419
420
         allocCode = toOL (map ALLOC sizes)
     in
421
422
     schemeE d' s p' b   				`thenBc`  \ bodyCode ->
     mapBc schemeR (zip xs rhss) 			`thenBc_`
423
424
425
426
427
428
429
430
431
432
433
434
435
     returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)


schemeE d s p (fvs, AnnCase scrut bndr alts)
   = let
        -- Top of stack is the return itbl, as usual.
        -- underneath it is the pointer to the alt_code BCO.
        -- When an alt is entered, it assumes the returned value is
        -- on top of the itbl.
        ret_frame_sizeW = 2

        -- Env and depth in which to compile the alts, not including
        -- any vars bound by the alts themselves
436
        d' = d + ret_frame_sizeW + taggedIdSizeW bndr
437
        p' = addToFM p bndr (d' - 1)
438

439
        scrut_primrep = typePrimRep (idType bndr)
440
        isAlgCase
441
           = case scrut_primrep of
442
443
444
445
446
                IntRep -> False ; FloatRep -> False ; DoubleRep -> False
                PtrRep -> True
                other  -> pprPanic "ByteCodeGen.schemeE" (ppr other)

        -- given an alt, return a discr and code for it.
447
        codeAlt alt@(discr, binds_f, rhs)
448
           | isAlgCase 
449
450
451
452
453
454
           = let binds_r      = reverse binds_f
                 binds_r_szsw = map untaggedIdSizeW binds_r
                 binds_szw    = sum binds_r_szsw
                 p''          = addListToFM 
                                   p' (zip binds_r (mkStackOffsets d' binds_r_szsw))
                 d''          = d' + binds_szw
455
                 unpack_code  = mkUnpackCode 0 0 (map (typePrimRep.idType) binds_f)
456
             in schemeE d'' s p'' rhs	`thenBc` \ rhs_code -> 
457
                returnBc (my_discr alt, unpack_code `appOL` rhs_code)
458
           | otherwise 
459
           = ASSERT(null binds_f) 
460
461
             schemeE d' s p' rhs	`thenBc` \ rhs_code ->
             returnBc (my_discr alt, rhs_code)
462

463
        my_discr (DEFAULT, binds, rhs)  = NoDiscr
464
        my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc)
465
        my_discr (LitAlt l, binds, rhs)
466
           = case l of MachInt i     -> DiscrI (fromInteger i)
467
468
                       MachFloat r   -> DiscrF (fromRational r)
                       MachDouble r  -> DiscrD (fromRational r)
469

470
471
472
473
474
475
476
        maybe_ncons 
           | not isAlgCase = Nothing
           | otherwise 
           = case [dc | (DataAlt dc, _, _) <- alts] of
                []     -> Nothing
                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))

477
     in 
478
     mapBc codeAlt alts 				`thenBc` \ alt_stuff ->
479
     mkMultiBranch maybe_ncons alt_stuff		`thenBc` \ alt_final ->
480
481
     let 
         alt_bco_name = getName bndr
482
         alt_bco      = mkProtoBCO alt_bco_name alt_final (Left alts)
483
484
485
486
487
     in
     schemeE (d + ret_frame_sizeW) 
             (d + ret_frame_sizeW) p scrut		`thenBc` \ scrut_code ->

     emitBc alt_bco 					`thenBc_`
488
     returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
489
490
491
492
493
494
495
496


schemeE d s p (fvs, AnnNote note body)
   = schemeE d s p body

schemeE d s p other
   = pprPanic "ByteCodeGen.schemeE: unhandled case" 
               (pprCoreExpr (deAnnotate other))
497
498


499
500
501
502
503
504
-- Compile code to do a tail call.  Doesn't need to be monadic.
schemeT :: Bool 	-- do tagging?
        -> Int 		-- Stack depth
        -> Sequel 	-- Sequel depth
        -> Int 		-- # arg words so far
        -> BCEnv 	-- stack env
505
506
        -> AnnExpr Id VarSet 
        -> BCInstrList
507

508
509
510
511
512
513
514
schemeT enTag d s narg_words p (_, AnnApp f a)
   = case snd a of
        AnnType _ -> schemeT enTag d s narg_words p f
        other
           -> let (push, arg_words) = pushAtom enTag d p (snd a)
              in push 
                 `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
515
516
517
518

schemeT enTag d s narg_words p (_, AnnVar f)
   | Just con <- isDataConId_maybe f
   = ASSERT(enTag == False)
519
     PACK con narg_words `consOL` (mkSLIDE 1 (d-s-1) `snocOL` ENTER)
520
521
522
   | otherwise
   = ASSERT(enTag == True)
     let (push, arg_words) = pushAtom True d p (AnnVar f)
523
524
525
526
527
528
     in  push 
         `appOL`  mkSLIDE (narg_words+arg_words) (d - s - narg_words)
         `snocOL` ENTER

mkSLIDE n d 
   = if d == 0 then nilOL else unitOL (SLIDE n d)
529
530
531
532
533
534
535
536
537

should_args_be_tagged (_, AnnVar v)
   = case isDataConId_maybe v of
        Just dcon -> False; Nothing -> True
should_args_be_tagged (_, AnnApp f a)
   = should_args_be_tagged f
should_args_be_tagged (_, other)
   = panic "should_args_be_tagged: tail call to non-con, non-var"

538
539
540

-- Make code to unpack a constructor onto the stack, adding
-- tags for the unboxed bits.  Takes the PrimReps of the constructor's
541
542
543
544
545
-- arguments, and a travelling offset along both the constructor
-- (off_h) and the stack (off_s).
mkUnpackCode :: Int -> Int -> [PrimRep] -> BCInstrList
mkUnpackCode off_h off_s [] = nilOL
mkUnpackCode off_h off_s (r:rs)
546
547
548
549
   | isFollowableRep r
   = let (rs_ptr, rs_nptr) = span isFollowableRep (r:rs)
         ptrs_szw = sum (map untaggedSizeW rs_ptr) 
     in  ASSERT(ptrs_szw == length rs_ptr)
550
551
552
553
         ASSERT(off_h == 0)
         ASSERT(off_s == 0)
         UNPACK ptrs_szw 
         `consOL` mkUnpackCode (off_h + ptrs_szw) (off_s + ptrs_szw) rs_nptr
554
555
   | otherwise
   = case r of
556
557
558
        IntRep    -> approved
        FloatRep  -> approved
        DoubleRep -> approved
559
     where
560
561
562
563
        approved = UPK_TAG usizeW off_h off_s   `consOL` theRest
        theRest  = mkUnpackCode (off_h + usizeW) (off_s + tsizeW) rs
        usizeW   = untaggedSizeW r
        tsizeW   = taggedSizeW r
564

565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
-- Push an atom onto the stack, returning suitable code & number of
-- stack words used.  Pushes it either tagged or untagged, since 
-- pushAtom is used to set up the stack prior to copying into the
-- heap for both APs (requiring tags) and constructors (which don't).
--
-- NB this means NO GC between pushing atoms for a constructor and
-- copying them into the heap.  It probably also means that 
-- tail calls MUST be of the form atom{atom ... atom} since if the
-- expression head was allowed to be arbitrary, there could be GC
-- in between pushing the arg atoms and completing the head.
-- (not sure; perhaps the allocate/doYouWantToGC interface means this
-- isn't a problem; but only if arbitrary graph construction for the
-- head doesn't leave this BCO, since GC might happen at the start of
-- each BCO (we consult doYouWantToGC there).
--
-- Blargh.  JRS 001206
--
582
583
584
585
-- NB (further) that the env p must map each variable to the highest-
-- numbered stack slot for it.  For example, if the stack has depth 4 
-- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
-- the tag in stack[5], the stack will have depth 6, and p must map v to
586
587
-- 5 and not to 4.  Stack locations are numbered from zero, so a depth
-- 6 stack has valid words 0 .. 5.
588

589
pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
pushAtom tagged d p (AnnVar v) 
   = let str = "\npushAtom " ++ showSDocDebug (ppr v) ++ ", depth = " ++ show d
               ++ ", env =\n" ++ 
               showSDocDebug (nest 4 (vcat (map ppr (fmToList p))))
               ++ " -->\n" ++
               showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
               ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
         str' = if str == str then str else str

         result
            = case lookupBCEnv_maybe p v of
                 Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), sz_t)
                 Nothing  -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), sz_t)

         nm     = getName v
         sz_t   = taggedIdSizeW v
         sz_u   = untaggedIdSizeW v
         nwords = if tagged then sz_t else sz_u
     in
         --trace str'
         result
611
612

pushAtom True d p (AnnLit lit)
613
614
   = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
     in  (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
615
616
617

pushAtom False d p (AnnLit lit)
   = case lit of
618
619
620
        MachInt i    -> code IntRep
        MachFloat r  -> code FloatRep
        MachDouble r -> code DoubleRep
621
     where
622
623
        code rep
           = let size_host_words = untaggedSizeW rep
624
             in (unitOL (PUSH_UBX lit size_host_words), size_host_words)
625

626
627
628
pushAtom tagged d p (AnnApp f (_, AnnType _))
   = pushAtom tagged d p (snd f)

629
630
631
632
pushAtom tagged d p other
   = pprPanic "ByteCodeGen.pushAtom" 
              (pprCoreExpr (deAnnotate (undefined, other)))

633

634
635
636
-- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
637
638
639
640
641
642
mkMultiBranch :: Maybe Int	-- # datacons in tycon, if alg alt
				-- a hint; generates better code
				-- Nothing is always safe
              -> [(Discr, BCInstrList)] 
              -> BcM BCInstrList
mkMultiBranch maybe_ncons raw_ways
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
   = let d_way     = filter (isNoDiscr.fst) raw_ways
         notd_ways = naturalMergeSortLe 
                        (\w1 w2 -> leAlt (fst w1) (fst w2))
                        (filter (not.isNoDiscr.fst) raw_ways)

         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
         mkTree [] range_lo range_hi = returnBc the_default

         mkTree [val] range_lo range_hi
            | range_lo `eqAlt` range_hi 
            = returnBc (snd val)
            | otherwise
            = getLabelBc 				`thenBc` \ label_neq ->
              returnBc (mkTestEQ (fst val) label_neq 
			`consOL` (snd val
			`appOL`   unitOL (LABEL label_neq)
			`appOL`   the_default))

         mkTree vals range_lo range_hi
            = let n = length vals `div` 2
                  vals_lo = take n vals
                  vals_hi = drop n vals
                  v_mid = fst (head vals_hi)
              in
              getLabelBc 				`thenBc` \ label_geq ->
              mkTree vals_lo range_lo (dec v_mid) 	`thenBc` \ code_lo ->
              mkTree vals_hi v_mid range_hi 		`thenBc` \ code_hi ->
              returnBc (mkTestLT v_mid label_geq
                        `consOL` (code_lo
			`appOL`   unitOL (LABEL label_geq)
			`appOL`   code_hi))
 
         the_default 
            = case d_way of [] -> unitOL CASEFAIL
                            [(_, def)] -> def

         -- None of these will be needed if there are no non-default alts
         (mkTestLT, mkTestEQ, init_lo, init_hi)
            | null notd_ways
            = panic "mkMultiBranch: awesome foursome"
            | otherwise
            = case fst (head notd_ways) of {
              DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
                            \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
                            DiscrI minBound,
                            DiscrI maxBound );
              DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
                            \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
                            DiscrF minF,
                            DiscrF maxF );
              DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
                            \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
                            DiscrD minD,
                            DiscrD maxD );
              DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
                            \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
699
700
                            DiscrP algMinBound,
                            DiscrP algMaxBound )
701
702
              }

703
704
705
706
707
         (algMinBound, algMaxBound)
            = case maybe_ncons of
                 Just n  -> (fIRST_TAG, fIRST_TAG + n - 1)
                 Nothing -> (minBound, maxBound)

708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
         (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
         (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
         (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
         (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
         NoDiscr     `eqAlt` NoDiscr     = True
         _           `eqAlt` _           = False

         (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
         (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
         (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
         (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
         NoDiscr     `leAlt` NoDiscr     = True
         _           `leAlt` _           = False

         isNoDiscr NoDiscr = True
         isNoDiscr _       = False

         dec (DiscrI i) = DiscrI (i-1)
         dec (DiscrP i) = DiscrP (i-1)
         dec other      = other		-- not really right, but if you
		-- do cases on floating values, you'll get what you deserve

         -- same snotty comment applies to the following
         minF, maxF :: Float
         minD, maxD :: Double
         minF = -1.0e37
         maxF =  1.0e37
         minD = -1.0e308
         maxD =  1.0e308
     in
         mkTree notd_ways init_lo init_hi
739

740
741
\end{code}

742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
%************************************************************************
%*									*
\subsection{Supporting junk for the compilation schemes}
%*									*
%************************************************************************

\begin{code}

-- Describes case alts
data Discr 
   = DiscrI Int
   | DiscrF Float
   | DiscrD Double
   | DiscrP Int
   | NoDiscr

instance Outputable Discr where
   ppr (DiscrI i) = int i
   ppr (DiscrF f) = text (show f)
   ppr (DiscrD d) = text (show d)
   ppr (DiscrP i) = int i
   ppr NoDiscr    = text "DEF"


-- Find things in the BCEnv (the what's-on-the-stack-env)
767
-- See comment preceding pushAtom for precise meaning of env contents
768
769
770
771
772
773
--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
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803

lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
lookupBCEnv_maybe = lookupFM


-- When I push one of these on the stack, how much does Sp move by?
taggedSizeW :: PrimRep -> Int
taggedSizeW pr
   | isFollowableRep pr = 1
   | otherwise          = 1{-the tag-} + getPrimRepSize pr


-- The plain size of something, without tag.
untaggedSizeW :: PrimRep -> Int
untaggedSizeW pr
   | isFollowableRep pr = 1
   | otherwise          = getPrimRepSize pr


taggedIdSizeW, untaggedIdSizeW :: Id -> Int
taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
untaggedIdSizeW = untaggedSizeW . typePrimRep . idType

\end{code}

%************************************************************************
%*									*
\subsection{The bytecode generator's monad}
%*									*
%************************************************************************
804
805

\begin{code}
806
data BcM_State 
807
   = BcM_State { bcos      :: [ProtoBCO Name],	-- accumulates completed BCOs
808
                 nextlabel :: Int }		-- for generating local labels
809
810
811

type BcM result = BcM_State -> (result, BcM_State)

812
813
runBc :: BcM_State -> BcM () -> BcM_State
runBc init_st m = case m init_st of { (r,st) -> st }
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832

thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc expr cont st
  = case expr st of { (result, st') -> cont result st' }

thenBc_ :: BcM a -> BcM b -> BcM b
thenBc_ expr cont st
  = case expr st of { (result, st') -> cont st' }

returnBc :: a -> BcM a
returnBc result st = (result, st)

mapBc :: (a -> BcM b) -> [a] -> BcM [b]
mapBc f []     = returnBc []
mapBc f (x:xs)
  = f x          `thenBc` \ r  ->
    mapBc f xs   `thenBc` \ rs ->
    returnBc (r:rs)

833
emitBc :: ProtoBCO Name -> BcM ()
834
835
836
837
838
839
emitBc bco st
   = ((), st{bcos = bco : bcos st})

getLabelBc :: BcM Int
getLabelBc st
   = (nextlabel st, st{nextlabel = 1 + nextlabel st})
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857

\end{code}

%************************************************************************
%*									*
\subsection{The bytecode assembler}
%*									*
%************************************************************************

The object format for bytecodes is: 16 bits for the opcode, and 16 for
each field -- so the code can be considered a sequence of 16-bit ints.
Each field denotes either a stack offset or number of items on the
stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
index into the literal table (eg PUSH_I/D/L), or a bytecode address in
this BCO.

\begin{code}
-- Top level assembler fn.
858
859
assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO

860
assembleBCO (ProtoBCO nm instrs origin)
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
   = let
         -- pass 1: collect up the offsets of the local labels
         label_env = mkLabelEnv emptyFM 0 instrs

         mkLabelEnv env i_offset [] = env
         mkLabelEnv env i_offset (i:is)
            = let new_env 
                     = case i of LABEL n -> addToFM env n i_offset ; _ -> env
              in  mkLabelEnv new_env (i_offset + instrSizeB i) is

         findLabel lab
            = case lookupFM label_env lab of
                 Just bco_offset -> bco_offset
                 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
     in
876
877
878
879
880
     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)
881
         let init_asm_state = (insns,lits,ptrs,itbls)
882
883
         (final_insns, final_lits, final_ptrs, final_itbls) 
            <- mkBits findLabel init_asm_state instrs         
884

885
         return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls)
886
887

-- instrs nonptrs ptrs itbls
888
889
890
891
892
893
894
895
896
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)
897
898
899


-- This is where all the action is (pass 2 of the assembler)
900
901
902
903
904
905
906
mkBits :: (Int -> Int) 			-- label finder
       -> AsmState
       -> [BCInstr]			-- instructions (in)
       -> IO AsmState

mkBits findLabel st proto_insns
  = foldM doInstr st proto_insns
907
908
909
910
911
912
913
914
915
916
917
918
919
    where
       doInstr :: AsmState -> BCInstr -> IO AsmState
       doInstr st i
          = case i of
               ARGCHECK  n        -> instr2 st i_ARGCHECK n
               PUSH_L    o1       -> instr2 st i_PUSH_L o1
               PUSH_LL   o1 o2    -> instr3 st i_PUSH_LL o1 o2
               PUSH_LLL  o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
               PUSH_G    nm       -> do (p, st2) <- ptr st nm
                                        instr2 st2 i_PUSH_G p
               PUSH_AS   nm pk    -> do (p, st2)  <- ptr st nm
                                        (np, st3) <- ret_itbl st2 pk
                                        instr3 st3 i_PUSH_AS p np
920
921
               PUSH_UBX  lit nws  -> do (np, st2) <- literal st lit
                                        instr3 st2 i_PUSH_UBX np nws
922
923
924
925
926
927
               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
               MKAP      off sz   -> instr3 st i_MKAP off sz
               UNPACK    n        -> instr2 st i_UNPACK n
               UPK_TAG   n m k    -> instr4 st i_UPK_TAG n m k
928
929
               PACK      dcon sz  -> do (itbl_no,st2) <- itbl st dcon
                                        instr3 st2 i_PACK itbl_no sz
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
               LABEL     lab      -> return st
               TESTLT_I  i l      -> do (np, st2) <- int st i
                                        instr3 st2 i_TESTLT_I np (findLabel l)
               TESTEQ_I  i l      -> do (np, st2) <- int st i
                                        instr3 st2 i_TESTEQ_I np (findLabel l)
               TESTLT_F  f l      -> do (np, st2) <- float st f
                                        instr3 st2 i_TESTLT_F np (findLabel l)
               TESTEQ_F  f l      -> do (np, st2) <- float st f
                                        instr3 st2 i_TESTEQ_F np (findLabel l)
               TESTLT_D  d l      -> do (np, st2) <- double st d
                                        instr3 st2 i_TESTLT_D np (findLabel l)
               TESTEQ_D  d l      -> do (np, st2) <- double st d
                                        instr3 st2 i_TESTEQ_D np (findLabel l)
               TESTLT_P  i l      -> do (np, st2) <- int st i
                                        instr3 st2 i_TESTLT_P np (findLabel l)
               TESTEQ_P  i l      -> do (np, st2) <- int st i
                                        instr3 st2 i_TESTEQ_P np (findLabel l)
               CASEFAIL           -> instr1 st i_CASEFAIL
               ENTER              -> instr1 st i_ENTER
               RETURN             -> instr1 st i_RETURN

       i2s :: Int -> Word16
       i2s = fromIntegral

954
       instr1 (st_i0,st_l0,st_p0,st_I0) i1
955
          = do st_i1 <- addToSS st_i0 (i2s i1)
956
               return (st_i1,st_l0,st_p0,st_I0)
957

958
       instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
959
960
          = do st_i1 <- addToSS st_i0 (i2s i1)
               st_i2 <- addToSS st_i1 (i2s i2)
961
               return (st_i2,st_l0,st_p0,st_I0)
962

963
       instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
964
965
966
          = do st_i1 <- addToSS st_i0 (i2s i1)
               st_i2 <- addToSS st_i1 (i2s i2)
               st_i3 <- addToSS st_i2 (i2s i3)
967
               return (st_i3,st_l0,st_p0,st_I0)
968

969
       instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
970
971
972
973
          = 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)
974
               return (st_i4,st_l0,st_p0,st_I0)
975

976
       float (st_i0,st_l0,st_p0,st_I0) f
977
978
979
          = do let ws = mkLitF f
               st_l1 <- addListToSS st_l0 ws
               return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
980

981
       double (st_i0,st_l0,st_p0,st_I0) d
982
983
984
          = do let ws = mkLitD d
               st_l1 <- addListToSS st_l0 ws
               return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
985

986
       int (st_i0,st_l0,st_p0,st_I0) i
987
988
989
          = do let ws = mkLitI i
               st_l1 <- addListToSS st_l0 ws
               return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
990

991
       addr (st_i0,st_l0,st_p0,st_I0) a
992
993
994
          = do let ws = mkLitA a
               st_l1 <- addListToSS st_l0 ws
               return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
995

996
       ptr (st_i0,st_l0,st_p0,st_I0) p
997
998
          = do st_p1 <- addToSS st_p0 p
               return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
999
1000

       itbl (st_i0,st_l0,st_p0,st_I0) dcon
1001
1002
          = do st_I1 <- addToSS st_I0 (getName dcon)
               return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
1003
1004
1005
1006
1007

       literal st (MachInt j)    = int st (fromIntegral j)
       literal st (MachFloat r)  = float st (fromRational r)
       literal st (MachDouble r) = double st (fromRational r)

1008
1009
1010
1011
1012
       ret_itbl st pk
          = addr st ret_itbl_addr
            where
               ret_itbl_addr 
                  = case pk of
1013
1014
1015
                       IntRep    -> stg_ctoi_ret_R1_info
                       FloatRep  -> stg_ctoi_ret_F1_info
                       DoubleRep -> stg_ctoi_ret_D1_info
1016
                    where  -- TEMP HACK
1017
1018
                       stg_ctoi_ret_F1_info = nullAddr
                       stg_ctoi_ret_D1_info = nullAddr
1019
                     
1020
1021
1022
foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_info :: Addr
--foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
--foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
1023
1024
1025
1026
1027

-- The size in bytes of an instruction.
instrSizeB :: BCInstr -> Int
instrSizeB instr
   = case instr of
1028
1029
1030
1031
1032
        ARGCHECK _     -> 4
        PUSH_L   _     -> 4
        PUSH_LL  _ _   -> 6
        PUSH_LLL _ _ _ -> 8
        PUSH_G   _     -> 4
1033
1034
1035
        PUSH_AS  _ _   -> 6
        PUSH_UBX _ _   -> 6
        PUSH_TAG _     -> 4
1036
1037
1038
1039
        SLIDE    _ _   -> 6
        ALLOC    _     -> 4
        MKAP     _ _   -> 6
        UNPACK   _     -> 4
1040
        UPK_TAG  _ _ _ -> 8
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
        PACK     _ _   -> 6
        LABEL    _     -> 4
        TESTLT_I _ _   -> 6
        TESTEQ_I _ _   -> 6
        TESTLT_F _ _   -> 6
        TESTEQ_F _ _   -> 6
        TESTLT_D _ _   -> 6
        TESTEQ_D _ _   -> 6
        TESTLT_P _ _   -> 6
        TESTEQ_P _ _   -> 6
        CASEFAIL       -> 2
        ENTER          -> 2
        RETURN         -> 2
1054
1055


1056
-- Make lists of host-sized words for literals, so that when the
1057
1058
-- words are placed in memory at increasing addresses, the
-- bit pattern is correct for the host's word size and endianness.
1059
1060
1061
1062
mkLitI :: Int    -> [Word]
mkLitF :: Float  -> [Word]
mkLitD :: Double -> [Word]
mkLitA :: Addr   -> [Word]
1063

1064
mkLitF f
1065
1066
1067
   = runST (do
        arr <- newFloatArray ((0::Int),0)
        writeFloatArray arr 0 f
1068
        f_arr <- castSTUArray arr
1069
        w0 <- readWordArray f_arr 0
1070
1071
1072
        return [w0]
     )

1073
mkLitD d
1074
   | wORD_SIZE == 4
1075
1076
1077
   = runST (do
        arr <- newDoubleArray ((0::Int),0)
        writeDoubleArray arr 0 d
1078
        d_arr <- castSTUArray arr
1079
1080
        w0 <- readWordArray d_arr 0
        w1 <- readWordArray d_arr 1
1081
1082
        return [w0,w1]
     )
1083
   | wORD_SIZE == 8
1084
   = runST (do
1085
1086
1087
1088
        arr <- newDoubleArray ((0::Int),0)
        writeDoubleArray arr 0 d
        d_arr <- castSTUArray arr
        w0 <- readWordArray d_arr 0
1089
1090
        return [w0]
     )
1091
1092

mkLitI i
1093
1094
1095
   = runST (do
        arr <- newIntArray ((0::Int),0)
        writeIntArray arr 0 i
1096
        i_arr <- castSTUArray arr
1097
1098
        w0 <- readWordArray i_arr 0
        return [w0]
1099
     )
1100

1101
mkLitA a
1102
1103
1104
   = runST (do
        arr <- newAddrArray ((0::Int),0)
        writeAddrArray arr 0 a
1105
        a_arr <- castSTUArray arr
1106
        w0 <- readWordArray a_arr 0
1107
1108
1109
        return [w0]
     )

1110
1111
\end{code}

1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
%************************************************************************
%*									*
\subsection{Linking interpretables into something we can run}
%*									*
%************************************************************************

\begin{code}

{- 
data BCO# = BCO# ByteArray# 		-- instrs   :: array Word16#
                 ByteArray# 		-- literals :: array Word32#
                 PtrArray# 		-- ptrs     :: Array HValue
                 ByteArray#		-- itbls    :: Array Addr#
-}

GLOBAL_VAR(v_cafTable, [], [HValue])

1129
1130
--addCAF :: HValue -> IO ()
--addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs)
1131

1132
1133
1134
1135
--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
1136
1137


1138
1139
1140
1141
linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO] 
         -> IO [HValue]   -- IO [BCO#] really
linkBCOs ie ce binds = mapM (linkBCO ie ce) binds

1142
1143
1144
1145
1146
1147
1148
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
1149
        linked_itbls <- mapM (lookupIE ie) itbls
1150
1151
1152
1153
1154

        let n_insns    = sizeSS insnsSS
            n_literals = sizeSS literalsSS
            n_ptrs     = sizeSS ptrsSS
            n_itbls    = sizeSS itblsSS
1155

1156
1157
1158
        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
1159

1160
1161
1162
            itbls_arr = array (0, n_itbls-1) (indexify linked_itbls)
                        :: UArray Int Addr
            itbls_barr = case itbls_arr of UArray lo hi barr -> barr
1163

1164
1165
1166
            insns_arr = array (0, n_insns-1) (indexify insns)
                        :: UArray Int Word16
            insns_barr = case insns_arr of UArray lo hi barr -> barr
1167

1168
1169
1170
1171
1172
1173
            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
1174
1175

        BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
1176

1177
1178
        return (unsafeCoerce# bco#)

1179

1180
1181
1182
data BCO = BCO BCO#

newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO
1183
1184
newBCO a b c d
   = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
1185
1186
1187
1188
1189
1190
1191
1192


lookupCE :: ClosureEnv -> Name -> HValue
lookupCE ce nm 
   = case lookupFM ce nm of
        Just aa -> unsafeCoerce# aa
        Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)

1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
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)
1203

1204
1205
1206
1207
1208
1209
-- HACK!!!  ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
   = _UNPK_(moduleNameFS (rdrNameModule rn)) 
     ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
     where rn = toRdrName n
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260


{-
lookupCon ie con = 
  case lookupFM ie con of
    Just (Ptr addr) -> return addr
    Nothing   -> do
	-- try looking up in the object files.
        m <- lookupSymbol (nameToCLabel con "con_info")
	case m of
	    Just addr -> return addr
  	    Nothing   -> pprPanic "linkIExpr" (ppr con)

-- nullary constructors don't have normal _con_info tables.
lookupNullaryCon ie con =
  case lookupFM ie con of
    Just (Ptr addr) -> return (ConApp addr)
    Nothing -> do
	-- try looking up in the object files.
	m <- lookupSymbol (nameToCLabel con "closure")
	case m of
	    Just (A# addr) -> return (Native (unsafeCoerce# addr))
	    Nothing   -> pprPanic "lookupNullaryCon" (ppr con)


lookupNative ce var =
  unsafeInterleaveIO (do
      case lookupFM ce var of
    	Just e  -> return (Native e)
    	Nothing -> do
    	    -- try looking up in the object files.
    	    let lbl = (nameToCLabel var "closure")
    	    m <- lookupSymbol lbl
    	    case m of
    		Just (A# addr)
		    -> do addCAF (unsafeCoerce# addr)
			  return (Native (unsafeCoerce# addr))
    		Nothing   -> pprPanic "linkIExpr" (ppr var)
  )

-- some VarI/VarP refer to top-level interpreted functions; we change
-- them into Natives here.
lookupVar ce f v =
  unsafeInterleaveIO (
	case lookupFM ce (getName v) of
	    Nothing -> return (f v)
	    Just e  -> return (Native e)
  )
-}
\end{code}

1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
%************************************************************************
%*									*
\subsection{Manufacturing of info tables for DataCons}
%*									*
%************************************************************************

\begin{code}

#if __GLASGOW_HASKELL__ <= 408
type ItblPtr = Addr
#else
type ItblPtr = Ptr StgInfoTable
#endif

-- Make info tables for the data decls in this module
mkITbls :: [TyCon] -> IO ItblEnv
mkITbls [] = return emptyFM
mkITbls (tc:tcs) = do itbls  <- mkITbl tc
                      itbls2 <- mkITbls tcs
                      return (itbls `plusFM` itbls2)

mkITbl :: TyCon -> IO ItblEnv
mkITbl tc
--   | trace ("TYCON: " ++ showSDoc (ppr tc)) False
--   = error "?!?!"
   | not (isDataTyCon tc) 
   = return emptyFM
   | n == length dcs  -- paranoia; this is an assertion.
   = make_constr_itbls dcs
     where
        dcs = tyConDataCons tc
        n   = tyConFamilySize tc

cONSTR :: Int
cONSTR = 1  -- as defined in ghc/includes/ClosureTypes.h

-- Assumes constructors are numbered from zero, not one
make_constr_itbls :: [DataCon] -> IO ItblEnv
make_constr_itbls cons
   | length cons <= 8
   = do is <- mapM mk_vecret_itbl (zip cons [0..])
	return (listToFM is)
   | otherwise
   = do is <- mapM mk_dirret_itbl (zip cons [0..])
	return (listToFM is)
     where
        mk_vecret_itbl (dcon, conNo)
           = mk_itbl dcon conNo (vecret_entry conNo)
        mk_dirret_itbl (dcon, conNo)
1310
           = mk_itbl dcon conNo stg_interp_constr_entry
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356

        mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
        mk_itbl dcon conNo entry_addr
           = let (tot_wds, ptr_wds, _) 
                    = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
                 ptrs = ptr_wds
                 nptrs  = tot_wds - ptr_wds
                 itbl  = StgInfoTable {
                           ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
                           tipe = fromIntegral cONSTR,
                           srtlen = fromIntegral conNo,
                           code0 = fromIntegral code0, code1 = fromIntegral code1,
                           code2 = fromIntegral code2, code3 = fromIntegral code3,
                           code4 = fromIntegral code4, code5 = fromIntegral code5,
                           code6 = fromIntegral code6, code7 = fromIntegral code7 
                        }
                 -- Make a piece of code to jump to "entry_label".
                 -- This is the only arch-dependent bit.
                 -- On x86, if entry_label has an address 0xWWXXYYZZ,
                 -- emit   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
                 -- which is
                 -- B8 ZZ YY XX WW FF E0
                 (code0,code1,code2,code3,code4,code5,code6,code7)
                    = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w, 
                             byte 2 entry_addr_w, byte 3 entry_addr_w, 
                       0xFF, 0xE0, 
                       0x90 {-nop-})

                 entry_addr_w :: Word32
                 entry_addr_w = fromIntegral (addrToInt entry_addr)
             in
                 do addr <- malloc
                    --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
                    --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
                    --putStrLn ("# nptrs of itbl is " ++ show nptrs)
                    poke addr itbl
                    return (getName dcon, addr `plusPtr` 8)


byte :: Int -> Word32 -> Word32
byte 0 w = w .&. 0xFF
byte 1 w = (w `shiftR` 8) .&. 0xFF
byte 2 w = (w `shiftR` 16) .&. 0xFF
byte 3 w = (w `shiftR` 24) .&. 0xFF


1357
1358
1359
1360
1361
1362
1363
1364
vecret_entry 0 = stg_interp_constr1_entry
vecret_entry 1 = stg_interp_constr2_entry
vecret_entry 2 = stg_interp_constr3_entry
vecret_entry 3 = stg_interp_constr4_entry
vecret_entry 4 = stg_interp_constr5_entry
vecret_entry 5 = stg_interp_constr6_entry
vecret_entry 6 = stg_interp_constr7_entry
vecret_entry 7 = stg_interp_constr8_entry
1365
1366

-- entry point for direct returns for created constr itbls
1367
foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr
1368
-- and the 8 vectored ones
1369
1370
1371
1372
1373
1374
1375
1376
foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr
foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr
foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr
foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr
foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr
foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr
foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr
foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462





-- Ultra-minimalist version specially for constructors
data StgInfoTable = StgInfoTable {
   ptrs :: Word16,
   nptrs :: Word16,
   srtlen :: Word16,
   tipe :: Word16,
   code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
}


instance Storable StgInfoTable where

   sizeOf itbl 
      = (sum . map (\f -> f itbl))
        [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
         fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3, 
         fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]

   alignment itbl 
      = (sum . map (\f -> f itbl))
        [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
         fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3, 
         fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]

   poke a0 itbl
      = do a1 <- store (ptrs   itbl) (castPtr a0)
           a2 <- store (nptrs  itbl) a1
           a3 <- store (tipe   itbl) a2
           a4 <- store (srtlen itbl) a3
           a5 <- store (code0  itbl) a4
           a6 <- store (code1  itbl) a5
           a7 <- store (code2  itbl) a6
           a8 <- store (code3  itbl) a7
           a9 <- store (code4  itbl) a8
           aA <- store (code5  itbl) a9
           aB <- store (code6  itbl) aA
           aC <- store (code7  itbl) aB
           return ()

   peek a0
      = do (a1,ptrs)   <- load (castPtr a0)
           (a2,nptrs)  <- load a1
           (a3,tipe)   <- load a2
           (a4,srtlen) <- load a3
           (a5,code0)  <- load a4
           (a6,code1)  <- load a5
           (a7,code2)  <- load a6
           (a8,code3)  <- load a7
           (a9,code4)  <- load a8
           (aA,code5)  <- load a9
           (aB,code6)  <- load aA
           (aC,code7)  <- load aB
           return StgInfoTable { ptrs = ptrs, nptrs = nptrs, 
                                 srtlen = srtlen, tipe = tipe,
                                 code0 = code0, code1 = code1, code2 = code2,
                                 code3 = code3, code4 = code4, code5 = code5,
                                 code6 = code6, code7 = code7 }

fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
fieldSz sel x = sizeOf (sel x)

fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
fieldAl sel x = alignment (sel x)

store :: Storable a => a -> Ptr a -> IO (Ptr b)
store x addr = do poke addr x
                  return (castPtr (addr `plusPtr` sizeOf x))

load :: Storable a => Ptr a -> IO (Ptr b, a)
load addr = do x <- peek addr
               return (castPtr (addr `plusPtr` sizeOf x), x)

\end{code}

%************************************************************************
%*									*
\subsection{Connect to actual values for bytecode opcodes}
%*									*
%************************************************************************

\begin{code}
1463

1464
#include "Bytecodes.h"
1465
1466

i_ARGCHECK = (bci_ARGCHECK :: Int)
1467
1468
i_PUSH_L   = (bci_PUSH_L :: Int)
i_PUSH_LL  = (bci_PUSH_LL :: Int)
1469
i_PUSH_LLL = (bci_PUSH_LLL :: Int)
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
i_PUSH_G   = (bci_PUSH_G :: Int)
i_PUSH_AS  = (bci_PUSH_AS :: Int)
i_PUSH_UBX = (bci_PUSH_UBX :: Int)
i_PUSH_TAG = (bci_PUSH_TAG :: Int)
i_SLIDE    = (bci_SLIDE :: Int)
i_ALLOC    = (bci_ALLOC :: Int)
i_MKAP     = (bci_MKAP :: Int)
i_UNPACK   = (bci_UNPACK :: Int)
i_UPK_TAG  = (bci_UPK_TAG :: Int)
i_PACK     = (bci_PACK :: Int)
1480
--i_LABEL    = (bci_LABEL :: Int)
1481
1482
1483
1484
1485
1486
1487
1488
1489
i_TESTLT_I = (bci_TESTLT_I :: Int)
i_TESTEQ_I = (bci_TESTEQ_I :: Int)
i_TESTLT_F = (bci_TESTLT_F :: Int)
i_TESTEQ_F = (bci_TESTEQ_F :: Int)
i_TESTLT_D = (bci_TESTLT_D :: Int)
i_TESTEQ_D = (bci_TESTEQ_D :: Int)
i_TESTLT_P = (bci_TESTLT_P :: Int)
i_TESTEQ_P = (bci_TESTEQ_P :: Int)
i_CASEFAIL = (bci_CASEFAIL :: Int)
1490
1491
i_ENTER    = (bci_ENTER :: Int)
i_RETURN   = (bci_RETURN :: Int)
1492

1493
\end{code}