Convert GHCi sources from .lhs to .hs
[ghc.git] / compiler / ghci / ByteCodeGen.hs
1 {-# LANGUAGE CPP, MagicHash #-}
2 --
3 -- (c) The University of Glasgow 2002-2006
4 --
5
6 -- | ByteCodeGen: Generate bytecode from Core
7 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
8
9 #include "HsVersions.h"
10
11 import ByteCodeInstr
12 import ByteCodeItbls
13 import ByteCodeAsm
14 import ByteCodeLink
15 import LibFFI
16
17 import DynFlags
18 import Outputable
19 import Platform
20 import Name
21 import MkId
22 import Id
23 import ForeignCall
24 import HscTypes
25 import CoreUtils
26 import CoreSyn
27 import PprCore
28 import Literal
29 import PrimOp
30 import CoreFVs
31 import Type
32 import DataCon
33 import TyCon
34 import Util
35 import VarSet
36 import TysPrim
37 import ErrUtils
38 import Unique
39 import FastString
40 import Panic
41 import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW )
42 import SMRep
43 import Bitmap
44 import OrdList
45
46 import Data.List
47 import Foreign
48 import Foreign.C
49
50 #if __GLASGOW_HASKELL__ < 709
51 import Control.Applicative (Applicative(..))
52 #endif
53 import Control.Monad
54 import Data.Char
55
56 import UniqSupply
57 import BreakArray
58 import Data.Maybe
59 import Module
60
61 import qualified Data.ByteString as BS
62 import qualified Data.ByteString.Unsafe as BS
63 import Data.Map (Map)
64 import qualified Data.Map as Map
65 import qualified FiniteMap as Map
66 import Data.Ord
67
68 -- -----------------------------------------------------------------------------
69 -- Generating byte code for a complete module
70
71 byteCodeGen :: DynFlags
72 -> Module
73 -> CoreProgram
74 -> [TyCon]
75 -> ModBreaks
76 -> IO CompiledByteCode
77 byteCodeGen dflags this_mod binds tycs modBreaks
78 = do showPass dflags "ByteCodeGen"
79
80 let flatBinds = [ (bndr, freeVars rhs)
81 | (bndr, rhs) <- flattenBinds binds]
82
83 us <- mkSplitUniqSupply 'y'
84 (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
85 <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
86
87 when (notNull mallocd)
88 (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
89
90 dumpIfSet_dyn dflags Opt_D_dump_BCOs
91 "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
92
93 assembleBCOs dflags proto_bcos tycs
94
95 -- -----------------------------------------------------------------------------
96 -- Generating byte code for an expression
97
98 -- Returns: (the root BCO for this expression,
99 -- a list of auxilary BCOs resulting from compiling closures)
100 coreExprToBCOs :: DynFlags
101 -> Module
102 -> CoreExpr
103 -> IO UnlinkedBCO
104 coreExprToBCOs dflags this_mod expr
105 = do showPass dflags "ByteCodeGen"
106
107 -- create a totally bogus name for the top-level BCO; this
108 -- should be harmless, since it's never used for anything
109 let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
110 invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
111
112 -- the uniques are needed to generate fresh variables when we introduce new
113 -- let bindings for ticked expressions
114 us <- mkSplitUniqSupply 'y'
115 (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
116 <- runBc dflags us this_mod emptyModBreaks $
117 schemeTopBind (invented_id, freeVars expr)
118
119 when (notNull mallocd)
120 (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
121
122 dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
123
124 assembleBCO dflags proto_bco
125
126
127 -- -----------------------------------------------------------------------------
128 -- Compilation schema for the bytecode generator
129
130 type BCInstrList = OrdList BCInstr
131
132 type Sequel = Word -- back off to this depth before ENTER
133
134 -- Maps Ids to the offset from the stack _base_ so we don't have
135 -- to mess with it after each push/pop.
136 type BCEnv = Map Id Word -- To find vars on the stack
137
138 {-
139 ppBCEnv :: BCEnv -> SDoc
140 ppBCEnv p
141 = text "begin-env"
142 $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
143 $$ text "end-env"
144 where
145 pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
146 cmp_snd x y = compare (snd x) (snd y)
147 -}
148
149 -- Create a BCO and do a spot of peephole optimisation on the insns
150 -- at the same time.
151 mkProtoBCO
152 :: DynFlags
153 -> name
154 -> BCInstrList
155 -> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)
156 -> Int
157 -> Word16
158 -> [StgWord]
159 -> Bool -- True <=> is a return point, rather than a function
160 -> [BcPtr]
161 -> ProtoBCO name
162 mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
163 = ProtoBCO {
164 protoBCOName = nm,
165 protoBCOInstrs = maybe_with_stack_check,
166 protoBCOBitmap = bitmap,
167 protoBCOBitmapSize = bitmap_size,
168 protoBCOArity = arity,
169 protoBCOExpr = origin,
170 protoBCOPtrs = mallocd_blocks
171 }
172 where
173 -- Overestimate the stack usage (in words) of this BCO,
174 -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
175 -- stack check. (The interpreter always does a stack check
176 -- for iNTERP_STACK_CHECK_THRESH words at the start of each
177 -- BCO anyway, so we only need to add an explicit one in the
178 -- (hopefully rare) cases when the (overestimated) stack use
179 -- exceeds iNTERP_STACK_CHECK_THRESH.
180 maybe_with_stack_check
181 | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
182 -- don't do stack checks at return points,
183 -- everything is aggregated up to the top BCO
184 -- (which must be a function).
185 -- That is, unless the stack usage is >= AP_STACK_SPLIM,
186 -- see bug #1466.
187 | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
188 = STKCHECK stack_usage : peep_d
189 | otherwise
190 = peep_d -- the supposedly common case
191
192 -- We assume that this sum doesn't wrap
193 stack_usage = sum (map bciStackUse peep_d)
194
195 -- Merge local pushes
196 peep_d = peep (fromOL instrs_ordlist)
197
198 peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
199 = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
200 peep (PUSH_L off1 : PUSH_L off2 : rest)
201 = PUSH_LL off1 (off2-1) : peep rest
202 peep (i:rest)
203 = i : peep rest
204 peep []
205 = []
206
207 argBits :: DynFlags -> [ArgRep] -> [Bool]
208 argBits _ [] = []
209 argBits dflags (rep : args)
210 | isFollowableArg rep = False : argBits dflags args
211 | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
212
213 -- -----------------------------------------------------------------------------
214 -- schemeTopBind
215
216 -- Compile code for the right-hand side of a top-level binding
217
218 schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
219
220
221 schemeTopBind (id, rhs)
222 | Just data_con <- isDataConWorkId_maybe id,
223 isNullaryRepDataCon data_con = do
224 dflags <- getDynFlags
225 -- Special case for the worker of a nullary data con.
226 -- It'll look like this: Nil = /\a -> Nil a
227 -- If we feed it into schemeR, we'll get
228 -- Nil = Nil
229 -- because mkConAppCode treats nullary constructor applications
230 -- by just re-using the single top-level definition. So
231 -- for the worker itself, we must allocate it directly.
232 -- ioToBc (putStrLn $ "top level BCO")
233 emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
234 (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
235
236 | otherwise
237 = schemeR [{- No free variables -}] (id, rhs)
238
239
240 -- -----------------------------------------------------------------------------
241 -- schemeR
242
243 -- Compile code for a right-hand side, to give a BCO that,
244 -- when executed with the free variables and arguments on top of the stack,
245 -- will return with a pointer to the result on top of the stack, after
246 -- removing the free variables and arguments.
247 --
248 -- Park the resulting BCO in the monad. Also requires the
249 -- variable to which this value was bound, so as to give the
250 -- resulting BCO a name.
251
252 schemeR :: [Id] -- Free vars of the RHS, ordered as they
253 -- will appear in the thunk. Empty for
254 -- top-level things, which have no free vars.
255 -> (Id, AnnExpr Id VarSet)
256 -> BcM (ProtoBCO Name)
257 schemeR fvs (nm, rhs)
258 {-
259 | trace (showSDoc (
260 (char ' '
261 $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
262 $$ pprCoreExpr (deAnnotate rhs)
263 $$ char ' '
264 ))) False
265 = undefined
266 | otherwise
267 -}
268 = schemeR_wrk fvs nm rhs (collect rhs)
269
270 collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
271 collect (_, e) = go [] e
272 where
273 go xs e | Just e' <- bcView e = go xs e'
274 go xs (AnnLam x (_,e))
275 | UbxTupleRep _ <- repType (idType x)
276 = unboxedTupleException
277 | otherwise
278 = go (x:xs) e
279 go xs not_lambda = (reverse xs, not_lambda)
280
281 schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
282 schemeR_wrk fvs nm original_body (args, body)
283 = do
284 dflags <- getDynFlags
285 let
286 all_args = reverse args ++ fvs
287 arity = length all_args
288 -- all_args are the args in reverse order. We're compiling a function
289 -- \fv1..fvn x1..xn -> e
290 -- i.e. the fvs come first
291
292 szsw_args = map (fromIntegral . idSizeW dflags) all_args
293 szw_args = sum szsw_args
294 p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
295
296 -- make the arg bitmap
297 bits = argBits dflags (reverse (map bcIdArgRep all_args))
298 bitmap_size = genericLength bits
299 bitmap = mkBitmap dflags bits
300 body_code <- schemeER_wrk szw_args p_init body
301
302 emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
303 arity bitmap_size bitmap False{-not alts-})
304
305 -- introduce break instructions for ticked expressions
306 schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
307 schemeER_wrk d p rhs
308 | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
309 = do code <- schemeE (fromIntegral d) 0 p newRhs
310 arr <- getBreakArray
311 this_mod <- getCurrentModule
312 let idOffSets = getVarOffSets d p fvs
313 let breakInfo = BreakInfo
314 { breakInfo_module = this_mod
315 , breakInfo_number = tick_no
316 , breakInfo_vars = idOffSets
317 , breakInfo_resty = exprType (deAnnotate' newRhs)
318 }
319 let breakInstr = case arr of
320 BA arr# ->
321 BRK_FUN arr# (fromIntegral tick_no) breakInfo
322 return $ breakInstr `consOL` code
323 | otherwise = schemeE (fromIntegral d) 0 p rhs
324
325 getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
326 getVarOffSets d p = catMaybes . map (getOffSet d p)
327
328 getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)
329 getOffSet d env id
330 = case lookupBCEnv_maybe id env of
331 Nothing -> Nothing
332 Just offset -> Just (id, trunc16 $ d - offset)
333
334 trunc16 :: Word -> Word16
335 trunc16 w
336 | w > fromIntegral (maxBound :: Word16)
337 = panic "stack depth overflow"
338 | otherwise
339 = fromIntegral w
340
341 fvsToEnv :: BCEnv -> VarSet -> [Id]
342 -- Takes the free variables of a right-hand side, and
343 -- delivers an ordered list of the local variables that will
344 -- be captured in the thunk for the RHS
345 -- The BCEnv argument tells which variables are in the local
346 -- environment: these are the ones that should be captured
347 --
348 -- The code that constructs the thunk, and the code that executes
349 -- it, have to agree about this layout
350 fvsToEnv p fvs = [v | v <- varSetElems fvs,
351 isId v, -- Could be a type variable
352 v `Map.member` p]
353
354 -- -----------------------------------------------------------------------------
355 -- schemeE
356
357 returnUnboxedAtom :: Word -> Sequel -> BCEnv
358 -> AnnExpr' Id VarSet -> ArgRep
359 -> BcM BCInstrList
360 -- Returning an unlifted value.
361 -- Heave it on the stack, SLIDE, and RETURN.
362 returnUnboxedAtom d s p e e_rep
363 = do (push, szw) <- pushAtom d p e
364 return (push -- value onto stack
365 `appOL` mkSLIDE szw (d-s) -- clear to sequel
366 `snocOL` RETURN_UBX e_rep) -- go
367
368 -- Compile code to apply the given expression to the remaining args
369 -- on the stack, returning a HNF.
370 schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
371
372 schemeE d s p e
373 | Just e' <- bcView e
374 = schemeE d s p e'
375
376 -- Delegate tail-calls to schemeT.
377 schemeE d s p e@(AnnApp _ _) = schemeT d s p e
378
379 schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
380 schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
381
382 schemeE d s p e@(AnnVar v)
383 | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
384 | otherwise = schemeT d s p e
385
386 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
387 | (AnnVar v, args_r_to_l) <- splitApp rhs,
388 Just data_con <- isDataConWorkId_maybe v,
389 dataConRepArity data_con == length args_r_to_l
390 = do -- Special case for a non-recursive let whose RHS is a
391 -- saturatred constructor application.
392 -- Just allocate the constructor and carry on
393 alloc_code <- mkConAppCode d s p data_con args_r_to_l
394 body_code <- schemeE (d+1) s (Map.insert x d p) body
395 return (alloc_code `appOL` body_code)
396
397 -- General case for let. Generates correct, if inefficient, code in
398 -- all situations.
399 schemeE d s p (AnnLet binds (_,body)) = do
400 dflags <- getDynFlags
401 let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
402 AnnRec xs_n_rhss -> unzip xs_n_rhss
403 n_binds = genericLength xs
404
405 fvss = map (fvsToEnv p' . fst) rhss
406
407 -- Sizes of free vars
408 sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss
409
410 -- the arity of each rhs
411 arities = map (genericLength . fst . collect) rhss
412
413 -- This p', d' defn is safe because all the items being pushed
414 -- are ptrs, so all have size 1. d' and p' reflect the stack
415 -- after the closures have been allocated in the heap (but not
416 -- filled in), and pointers to them parked on the stack.
417 p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
418 d' = d + fromIntegral n_binds
419 zipE = zipEqual "schemeE"
420
421 -- ToDo: don't build thunks for things with no free variables
422 build_thunk _ [] size bco off arity
423 = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
424 where
425 mkap | arity == 0 = MKAP
426 | otherwise = MKPAP
427 build_thunk dd (fv:fvs) size bco off arity = do
428 (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
429 more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
430 return (push_code `appOL` more_push_code)
431
432 alloc_code = toOL (zipWith mkAlloc sizes arities)
433 where mkAlloc sz 0
434 | is_tick = ALLOC_AP_NOUPD sz
435 | otherwise = ALLOC_AP sz
436 mkAlloc sz arity = ALLOC_PAP arity sz
437
438 is_tick = case binds of
439 AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
440 _other -> False
441
442 compile_bind d' fvs x rhs size arity off = do
443 bco <- schemeR fvs (x,rhs)
444 build_thunk d' fvs size bco off arity
445
446 compile_binds =
447 [ compile_bind d' fvs x rhs size arity n
448 | (fvs, x, rhs, size, arity, n) <-
449 zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
450 ]
451 body_code <- schemeE d' s p' body
452 thunk_codes <- sequence compile_binds
453 return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
454
455 -- introduce a let binding for a ticked case expression. This rule
456 -- *should* only fire when the expression was not already let-bound
457 -- (the code gen for let bindings should take care of that). Todo: we
458 -- call exprFreeVars on a deAnnotated expression, this may not be the
459 -- best way to calculate the free vars but it seemed like the least
460 -- intrusive thing to do
461 schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
462 = if isUnLiftedType ty
463 then do
464 -- If the result type is unlifted, then we must generate
465 -- let f = \s . tick<n> e
466 -- in f realWorld#
467 -- When we stop at the breakpoint, _result will have an unlifted
468 -- type and hence won't be bound in the environment, but the
469 -- breakpoint will otherwise work fine.
470 id <- newId (mkFunTy realWorldStatePrimTy ty)
471 st <- newId realWorldStatePrimTy
472 let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
473 (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
474 (emptyVarSet, AnnVar realWorldPrimId)))
475 schemeE d s p letExp
476 else do
477 id <- newId ty
478 -- Todo: is emptyVarSet correct on the next line?
479 let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
480 schemeE d s p letExp
481 where exp' = deAnnotate' exp
482 fvs = exprFreeVars exp'
483 ty = exprType exp'
484
485 -- ignore other kinds of tick
486 schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
487
488 schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
489 -- no alts: scrut is guaranteed to diverge
490
491 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
492 | isUnboxedTupleCon dc
493 , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2)
494 -- Convert
495 -- case .... of x { (# V'd-thing, a #) -> ... }
496 -- to
497 -- case .... of a { DEFAULT -> ... }
498 -- becuse the return convention for both are identical.
499 --
500 -- Note that it does not matter losing the void-rep thing from the
501 -- envt (it won't be bound now) because we never look such things up.
502 , Just res <- case () of
503 _ | VoidRep <- typePrimRep rep_ty1
504 -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
505 | VoidRep <- typePrimRep rep_ty2
506 -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
507 | otherwise
508 -> Nothing
509 = res
510
511 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
512 | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1)
513 -- Similarly, convert
514 -- case .... of x { (# a #) -> ... }
515 -- to
516 -- case .... of a { DEFAULT -> ... }
517 = --trace "automagic mashing of case alts (# a #)" $
518 doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
519
520 schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)])
521 | Just (tc, tys) <- splitTyConApp_maybe (idType bndr)
522 , isUnboxedTupleTyCon tc
523 , Just res <- case tys of
524 [ty] | UnaryRep _ <- repType ty
525 , let bind = bndr `setIdType` ty
526 -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
527 [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1
528 , UnaryRep rep_ty2 <- repType ty2
529 -> case () of
530 _ | VoidRep <- typePrimRep rep_ty1
531 , let bind2 = bndr `setIdType` ty2
532 -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
533 | VoidRep <- typePrimRep rep_ty2
534 , let bind1 = bndr `setIdType` ty1
535 -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
536 | otherwise
537 -> Nothing
538 _ -> Nothing
539 = res
540
541 schemeE d s p (AnnCase scrut bndr _ alts)
542 = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
543
544 schemeE _ _ _ expr
545 = pprPanic "ByteCodeGen.schemeE: unhandled case"
546 (pprCoreExpr (deAnnotate' expr))
547
548 {-
549 Ticked Expressions
550 ------------------
551
552 The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
553 the code. When we find such a thing, we pull out the useful information,
554 and then compile the code as if it was just the expression E.
555
556 -}
557
558 -- Compile code to do a tail call. Specifically, push the fn,
559 -- slide the on-stack app back down to the sequel depth,
560 -- and enter. Four cases:
561 --
562 -- 0. (Nasty hack).
563 -- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
564 -- The int will be on the stack. Generate a code sequence
565 -- to convert it to the relevant constructor, SLIDE and ENTER.
566 --
567 -- 1. The fn denotes a ccall. Defer to generateCCall.
568 --
569 -- 2. (Another nasty hack). Spot (# a::V, b #) and treat
570 -- it simply as b -- since the representations are identical
571 -- (the V takes up zero stack space). Also, spot
572 -- (# b #) and treat it as b.
573 --
574 -- 3. Application of a constructor, by defn saturated.
575 -- Split the args into ptrs and non-ptrs, and push the nonptrs,
576 -- then the ptrs, and then do PACK and RETURN.
577 --
578 -- 4. Otherwise, it must be a function call. Push the args
579 -- right to left, SLIDE and ENTER.
580
581 schemeT :: Word -- Stack depth
582 -> Sequel -- Sequel depth
583 -> BCEnv -- stack env
584 -> AnnExpr' Id VarSet
585 -> BcM BCInstrList
586
587 schemeT d s p app
588
589 -- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
590 -- = panic "schemeT ?!?!"
591
592 -- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
593 -- = error "?!?!"
594
595 -- Case 0
596 | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
597 = implement_tagToId d s p arg constr_names
598
599 -- Case 1
600 | Just (CCall ccall_spec) <- isFCallId_maybe fn
601 = generateCCall d s p ccall_spec fn args_r_to_l
602
603 -- Case 2: Constructor application
604 | Just con <- maybe_saturated_dcon,
605 isUnboxedTupleCon con
606 = case args_r_to_l of
607 [arg1,arg2] | isVAtom arg1 ->
608 unboxedTupleReturn d s p arg2
609 [arg1,arg2] | isVAtom arg2 ->
610 unboxedTupleReturn d s p arg1
611 _other -> unboxedTupleException
612
613 -- Case 3: Ordinary data constructor
614 | Just con <- maybe_saturated_dcon
615 = do alloc_con <- mkConAppCode d s p con args_r_to_l
616 return (alloc_con `appOL`
617 mkSLIDE 1 (d - s) `snocOL`
618 ENTER)
619
620 -- Case 4: Tail call of function
621 | otherwise
622 = doTailCall d s p fn args_r_to_l
623
624 where
625 -- Extract the args (R->L) and fn
626 -- The function will necessarily be a variable,
627 -- because we are compiling a tail call
628 (AnnVar fn, args_r_to_l) = splitApp app
629
630 -- Only consider this to be a constructor application iff it is
631 -- saturated. Otherwise, we'll call the constructor wrapper.
632 n_args = length args_r_to_l
633 maybe_saturated_dcon
634 = case isDataConWorkId_maybe fn of
635 Just con | dataConRepArity con == n_args -> Just con
636 _ -> Nothing
637
638 -- -----------------------------------------------------------------------------
639 -- Generate code to build a constructor application,
640 -- leaving it on top of the stack
641
642 mkConAppCode :: Word -> Sequel -> BCEnv
643 -> DataCon -- The data constructor
644 -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
645 -> BcM BCInstrList
646
647 mkConAppCode _ _ _ con [] -- Nullary constructor
648 = ASSERT( isNullaryRepDataCon con )
649 return (unitOL (PUSH_G (getName (dataConWorkId con))))
650 -- Instead of doing a PACK, which would allocate a fresh
651 -- copy of this constructor, use the single shared version.
652
653 mkConAppCode orig_d _ p con args_r_to_l
654 = ASSERT( dataConRepArity con == length args_r_to_l )
655 do_pushery orig_d (non_ptr_args ++ ptr_args)
656 where
657 -- The args are already in reverse order, which is the way PACK
658 -- expects them to be. We must push the non-ptrs after the ptrs.
659 (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
660
661 do_pushery d (arg:args)
662 = do (push, arg_words) <- pushAtom d p arg
663 more_push_code <- do_pushery (d + fromIntegral arg_words) args
664 return (push `appOL` more_push_code)
665 do_pushery d []
666 = return (unitOL (PACK con n_arg_words))
667 where
668 n_arg_words = trunc16 $ d - orig_d
669
670
671 -- -----------------------------------------------------------------------------
672 -- Returning an unboxed tuple with one non-void component (the only
673 -- case we can handle).
674 --
675 -- Remember, we don't want to *evaluate* the component that is being
676 -- returned, even if it is a pointed type. We always just return.
677
678 unboxedTupleReturn
679 :: Word -> Sequel -> BCEnv
680 -> AnnExpr' Id VarSet -> BcM BCInstrList
681 unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
682
683 -- -----------------------------------------------------------------------------
684 -- Generate code for a tail-call
685
686 doTailCall
687 :: Word -> Sequel -> BCEnv
688 -> Id -> [AnnExpr' Id VarSet]
689 -> BcM BCInstrList
690 doTailCall init_d s p fn args
691 = do_pushes init_d args (map atomRep args)
692 where
693 do_pushes d [] reps = do
694 ASSERT( null reps ) return ()
695 (push_fn, sz) <- pushAtom d p (AnnVar fn)
696 ASSERT( sz == 1 ) return ()
697 return (push_fn `appOL` (
698 mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
699 unitOL ENTER))
700 do_pushes d args reps = do
701 let (push_apply, n, rest_of_reps) = findPushSeq reps
702 (these_args, rest_of_args) = splitAt n args
703 (next_d, push_code) <- push_seq d these_args
704 instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
705 -- ^^^ for the PUSH_APPLY_ instruction
706 return (push_code `appOL` (push_apply `consOL` instrs))
707
708 push_seq d [] = return (d, nilOL)
709 push_seq d (arg:args) = do
710 (push_code, sz) <- pushAtom d p arg
711 (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
712 return (final_d, push_code `appOL` more_push_code)
713
714 -- v. similar to CgStackery.findMatch, ToDo: merge
715 findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
716 findPushSeq (P: P: P: P: P: P: rest)
717 = (PUSH_APPLY_PPPPPP, 6, rest)
718 findPushSeq (P: P: P: P: P: rest)
719 = (PUSH_APPLY_PPPPP, 5, rest)
720 findPushSeq (P: P: P: P: rest)
721 = (PUSH_APPLY_PPPP, 4, rest)
722 findPushSeq (P: P: P: rest)
723 = (PUSH_APPLY_PPP, 3, rest)
724 findPushSeq (P: P: rest)
725 = (PUSH_APPLY_PP, 2, rest)
726 findPushSeq (P: rest)
727 = (PUSH_APPLY_P, 1, rest)
728 findPushSeq (V: rest)
729 = (PUSH_APPLY_V, 1, rest)
730 findPushSeq (N: rest)
731 = (PUSH_APPLY_N, 1, rest)
732 findPushSeq (F: rest)
733 = (PUSH_APPLY_F, 1, rest)
734 findPushSeq (D: rest)
735 = (PUSH_APPLY_D, 1, rest)
736 findPushSeq (L: rest)
737 = (PUSH_APPLY_L, 1, rest)
738 findPushSeq _
739 = panic "ByteCodeGen.findPushSeq"
740
741 -- -----------------------------------------------------------------------------
742 -- Case expressions
743
744 doCase :: Word -> Sequel -> BCEnv
745 -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
746 -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
747 -> BcM BCInstrList
748 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
749 | UbxTupleRep _ <- repType (idType bndr)
750 = unboxedTupleException
751 | otherwise
752 = do
753 dflags <- getDynFlags
754 let
755 -- Top of stack is the return itbl, as usual.
756 -- underneath it is the pointer to the alt_code BCO.
757 -- When an alt is entered, it assumes the returned value is
758 -- on top of the itbl.
759 ret_frame_sizeW :: Word
760 ret_frame_sizeW = 2
761
762 -- An unlifted value gets an extra info table pushed on top
763 -- when it is returned.
764 unlifted_itbl_sizeW :: Word
765 unlifted_itbl_sizeW | isAlgCase = 0
766 | otherwise = 1
767
768 -- depth of stack after the return value has been pushed
769 d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
770
771 -- depth of stack after the extra info table for an unboxed return
772 -- has been pushed, if any. This is the stack depth at the
773 -- continuation.
774 d_alts = d_bndr + unlifted_itbl_sizeW
775
776 -- Env in which to compile the alts, not including
777 -- any vars bound by the alts themselves
778 d_bndr' = fromIntegral d_bndr - 1
779 p_alts0 = Map.insert bndr d_bndr' p
780 p_alts = case is_unboxed_tuple of
781 Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0
782 Nothing -> p_alts0
783
784 bndr_ty = idType bndr
785 isAlgCase = not (isUnLiftedType bndr_ty) && isNothing is_unboxed_tuple
786
787 -- given an alt, return a discr and code for it.
788 codeAlt (DEFAULT, _, (_,rhs))
789 = do rhs_code <- schemeE d_alts s p_alts rhs
790 return (NoDiscr, rhs_code)
791
792 codeAlt alt@(_, bndrs, (_,rhs))
793 -- primitive or nullary constructor alt: no need to UNPACK
794 | null real_bndrs = do
795 rhs_code <- schemeE d_alts s p_alts rhs
796 return (my_discr alt, rhs_code)
797 | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs
798 = unboxedTupleException
799 -- algebraic alt with some binders
800 | otherwise =
801 let
802 (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs
803 ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs
804 nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs
805 bind_sizes = ptr_sizes ++ nptrs_sizes
806 size = sum ptr_sizes + sum nptrs_sizes
807 -- the UNPACK instruction unpacks in reverse order...
808 p' = Map.insertList
809 (zip (reverse (ptrs ++ nptrs))
810 (mkStackOffsets d_alts (reverse bind_sizes)))
811 p_alts
812 in do
813 MASSERT(isAlgCase)
814 rhs_code <- schemeE (d_alts + size) s p' rhs
815 return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
816 where
817 real_bndrs = filterOut isTyVar bndrs
818
819 my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
820 my_discr (DataAlt dc, _, _)
821 | isUnboxedTupleCon dc
822 = unboxedTupleException
823 | otherwise
824 = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
825 my_discr (LitAlt l, _, _)
826 = case l of MachInt i -> DiscrI (fromInteger i)
827 MachWord w -> DiscrW (fromInteger w)
828 MachFloat r -> DiscrF (fromRational r)
829 MachDouble r -> DiscrD (fromRational r)
830 MachChar i -> DiscrI (ord i)
831 _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
832
833 maybe_ncons
834 | not isAlgCase = Nothing
835 | otherwise
836 = case [dc | (DataAlt dc, _, _) <- alts] of
837 [] -> Nothing
838 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
839
840 -- the bitmap is relative to stack depth d, i.e. before the
841 -- BCO, info table and return value are pushed on.
842 -- This bit of code is v. similar to buildLivenessMask in CgBindery,
843 -- except that here we build the bitmap from the known bindings of
844 -- things that are pointers, whereas in CgBindery the code builds the
845 -- bitmap from the free slots and unboxed bindings.
846 -- (ToDo: merge?)
847 --
848 -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
849 -- The bitmap must cover the portion of the stack up to the sequel only.
850 -- Previously we were building a bitmap for the whole depth (d), but we
851 -- really want a bitmap up to depth (d-s). This affects compilation of
852 -- case-of-case expressions, which is the only time we can be compiling a
853 -- case expression with s /= 0.
854 bitmap_size = trunc16 $ d-s
855 bitmap_size' :: Int
856 bitmap_size' = fromIntegral bitmap_size
857 bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
858 (sort (filter (< bitmap_size') rel_slots))
859 where
860 binds = Map.toList p
861 -- NB: unboxed tuple cases bind the scrut binder to the same offset
862 -- as one of the alt binders, so we have to remove any duplicates here:
863 rel_slots = nub $ map fromIntegral $ concat (map spread binds)
864 spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
865 | otherwise = []
866 where rel_offset = trunc16 $ d - fromIntegral offset - 1
867
868 alt_stuff <- mapM codeAlt alts
869 alt_final <- mkMultiBranch maybe_ncons alt_stuff
870
871 let
872 alt_bco_name = getName bndr
873 alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
874 0{-no arity-} bitmap_size bitmap True{-is alts-}
875 -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
876 -- "\n bitmap = " ++ show bitmap) $ do
877 scrut_code <- schemeE (d + ret_frame_sizeW)
878 (d + ret_frame_sizeW)
879 p scrut
880 alt_bco' <- emitBc alt_bco
881 let push_alts
882 | isAlgCase = PUSH_ALTS alt_bco'
883 | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
884 return (push_alts `consOL` scrut_code)
885
886
887 -- -----------------------------------------------------------------------------
888 -- Deal with a CCall.
889
890 -- Taggedly push the args onto the stack R->L,
891 -- deferencing ForeignObj#s and adjusting addrs to point to
892 -- payloads in Ptr/Byte arrays. Then, generate the marshalling
893 -- (machine) code for the ccall, and create bytecodes to call that and
894 -- then return in the right way.
895
896 generateCCall :: Word -> Sequel -- stack and sequel depths
897 -> BCEnv
898 -> CCallSpec -- where to call
899 -> Id -- of target, for type info
900 -> [AnnExpr' Id VarSet] -- args (atoms)
901 -> BcM BCInstrList
902
903 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
904 = do
905 dflags <- getDynFlags
906
907 let
908 -- useful constants
909 addr_sizeW :: Word16
910 addr_sizeW = fromIntegral (argRepSizeW dflags N)
911
912 -- Get the args on the stack, with tags and suitably
913 -- dereferenced for the CCall. For each arg, return the
914 -- depth to the first word of the bits for that arg, and the
915 -- ArgRep of what was actually pushed.
916
917 pargs _ [] = return []
918 pargs d (a:az)
919 = let UnaryRep arg_ty = repType (exprType (deAnnotate' a))
920
921 in case tyConAppTyCon_maybe arg_ty of
922 -- Don't push the FO; instead push the Addr# it
923 -- contains.
924 Just t
925 | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
926 -> do rest <- pargs (d + fromIntegral addr_sizeW) az
927 code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
928 return ((code,AddrRep):rest)
929
930 | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
931 -> do rest <- pargs (d + fromIntegral addr_sizeW) az
932 code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
933 return ((code,AddrRep):rest)
934
935 | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
936 -> do rest <- pargs (d + fromIntegral addr_sizeW) az
937 code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
938 return ((code,AddrRep):rest)
939
940 -- Default case: push taggedly, but otherwise intact.
941 _
942 -> do (code_a, sz_a) <- pushAtom d p a
943 rest <- pargs (d + fromIntegral sz_a) az
944 return ((code_a, atomPrimRep a) : rest)
945
946 -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
947 -- the stack but then advance it over the headers, so as to
948 -- point to the payload.
949 parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet
950 -> BcM BCInstrList
951 parg_ArrayishRep hdrSize d p a
952 = do (push_fo, _) <- pushAtom d p a
953 -- The ptr points at the header. Advance it over the
954 -- header and then pretend this is an Addr#.
955 return (push_fo `snocOL` SWIZZLE 0 hdrSize)
956
957 code_n_reps <- pargs d0 args_r_to_l
958 let
959 (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
960 a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
961
962 push_args = concatOL pushs_arg
963 d_after_args = d0 + a_reps_sizeW
964 a_reps_pushed_RAW
965 | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
966 = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
967 | otherwise
968 = reverse (tail a_reps_pushed_r_to_l)
969
970 -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
971 -- push_args is the code to do that.
972 -- d_after_args is the stack depth once the args are on.
973
974 -- Get the result rep.
975 (returns_void, r_rep)
976 = case maybe_getCCallReturnRep (idType fn) of
977 Nothing -> (True, VoidRep)
978 Just rr -> (False, rr)
979 {-
980 Because the Haskell stack grows down, the a_reps refer to
981 lowest to highest addresses in that order. The args for the call
982 are on the stack. Now push an unboxed Addr# indicating
983 the C function to call. Then push a dummy placeholder for the
984 result. Finally, emit a CCALL insn with an offset pointing to the
985 Addr# just pushed, and a literal field holding the mallocville
986 address of the piece of marshalling code we generate.
987 So, just prior to the CCALL insn, the stack looks like this
988 (growing down, as usual):
989
990 <arg_n>
991 ...
992 <arg_1>
993 Addr# address_of_C_fn
994 <placeholder-for-result#> (must be an unboxed type)
995
996 The interpreter then calls the marshall code mentioned
997 in the CCALL insn, passing it (& <placeholder-for-result#>),
998 that is, the addr of the topmost word in the stack.
999 When this returns, the placeholder will have been
1000 filled in. The placeholder is slid down to the sequel
1001 depth, and we RETURN.
1002
1003 This arrangement makes it simple to do f-i-dynamic since the Addr#
1004 value is the first arg anyway.
1005
1006 The marshalling code is generated specifically for this
1007 call site, and so knows exactly the (Haskell) stack
1008 offsets of the args, fn address and placeholder. It
1009 copies the args to the C stack, calls the stacked addr,
1010 and parks the result back in the placeholder. The interpreter
1011 calls it as a normal C call, assuming it has a signature
1012 void marshall_code ( StgWord* ptr_to_top_of_stack )
1013 -}
1014 -- resolve static address
1015 get_target_info = do
1016 case target of
1017 DynamicTarget
1018 -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
1019
1020 StaticTarget _ _ False ->
1021 panic "generateCCall: unexpected FFI value import"
1022 StaticTarget target _ True
1023 -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
1024 return (True, res)
1025 where
1026 stdcall_adj_target
1027 | OSMinGW32 <- platformOS (targetPlatform dflags)
1028 , StdCallConv <- cconv
1029 = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in
1030 mkFastString (unpackFS target ++ '@':show size)
1031 | otherwise
1032 = target
1033
1034 (is_static, static_target_addr) <- get_target_info
1035 let
1036
1037 -- Get the arg reps, zapping the leading Addr# in the dynamic case
1038 a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
1039 | is_static = a_reps_pushed_RAW
1040 | otherwise = if null a_reps_pushed_RAW
1041 then panic "ByteCodeGen.generateCCall: dyn with no args"
1042 else tail a_reps_pushed_RAW
1043
1044 -- push the Addr#
1045 (push_Addr, d_after_Addr)
1046 | is_static
1047 = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
1048 d_after_args + fromIntegral addr_sizeW)
1049 | otherwise -- is already on the stack
1050 = (nilOL, d_after_args)
1051
1052 -- Push the return placeholder. For a call returning nothing,
1053 -- this is a V (tag).
1054 r_sizeW = fromIntegral (primRepSizeW dflags r_rep)
1055 d_after_r = d_after_Addr + fromIntegral r_sizeW
1056 r_lit = mkDummyLiteral r_rep
1057 push_r = (if returns_void
1058 then nilOL
1059 else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
1060
1061 -- generate the marshalling code we're going to call
1062
1063 -- Offset of the next stack frame down the stack. The CCALL
1064 -- instruction needs to describe the chunk of stack containing
1065 -- the ccall args to the GC, so it needs to know how large it
1066 -- is. See comment in Interpreter.c with the CCALL instruction.
1067 stk_offset = trunc16 $ d_after_r - s
1068
1069 -- the only difference in libffi mode is that we prepare a cif
1070 -- describing the call type by calling libffi, and we attach the
1071 -- address of this to the CCALL instruction.
1072 token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep
1073 let addr_of_marshaller = castPtrToFunPtr token
1074
1075 recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
1076 let
1077 -- do the call
1078 do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
1079 (fromIntegral (fromEnum (playInterruptible safety))))
1080 -- slide and return
1081 wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
1082 `snocOL` RETURN_UBX (toArgRep r_rep)
1083 --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
1084 return (
1085 push_args `appOL`
1086 push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
1087 )
1088
1089 -- Make a dummy literal, to be used as a placeholder for FFI return
1090 -- values on the stack.
1091 mkDummyLiteral :: PrimRep -> Literal
1092 mkDummyLiteral pr
1093 = case pr of
1094 IntRep -> MachInt 0
1095 WordRep -> MachWord 0
1096 AddrRep -> MachNullAddr
1097 DoubleRep -> MachDouble 0
1098 FloatRep -> MachFloat 0
1099 Int64Rep -> MachInt64 0
1100 Word64Rep -> MachWord64 0
1101 _ -> panic "mkDummyLiteral"
1102
1103
1104 -- Convert (eg)
1105 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1106 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
1107 --
1108 -- to Just IntRep
1109 -- and check that an unboxed pair is returned wherein the first arg is V'd.
1110 --
1111 -- Alternatively, for call-targets returning nothing, convert
1112 --
1113 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1114 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
1115 --
1116 -- to Nothing
1117
1118 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
1119 maybe_getCCallReturnRep fn_ty
1120 = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
1121 maybe_r_rep_to_go
1122 = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
1123 r_reps = case repType r_ty of
1124 UbxTupleRep reps -> map typePrimRep reps
1125 UnaryRep _ -> blargh
1126 ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
1127 || r_reps == [VoidRep] )
1128 && case maybe_r_rep_to_go of
1129 Nothing -> True
1130 Just r_rep -> r_rep /= PtrRep
1131 -- if it was, it would be impossible
1132 -- to create a valid return value
1133 -- placeholder on the stack
1134
1135 blargh :: a -- Used at more than one type
1136 blargh = pprPanic "maybe_getCCallReturn: can't handle:"
1137 (pprType fn_ty)
1138 in
1139 --trace (showSDoc (ppr (a_reps, r_reps))) $
1140 if ok then maybe_r_rep_to_go else blargh
1141
1142 maybe_is_tagToEnum_call :: AnnExpr' Id VarSet -> Maybe (AnnExpr' Id VarSet, [Name])
1143 -- Detect and extract relevant info for the tagToEnum kludge.
1144 maybe_is_tagToEnum_call app
1145 | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
1146 , Just TagToEnumOp <- isPrimOpId_maybe v
1147 = Just (snd arg, extract_constr_Names t)
1148 | otherwise
1149 = Nothing
1150 where
1151 extract_constr_Names ty
1152 | UnaryRep rep_ty <- repType ty
1153 , Just tyc <- tyConAppTyCon_maybe rep_ty,
1154 isDataTyCon tyc
1155 = map (getName . dataConWorkId) (tyConDataCons tyc)
1156 -- NOTE: use the worker name, not the source name of
1157 -- the DataCon. See DataCon.lhs for details.
1158 | otherwise
1159 = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
1160
1161 {- -----------------------------------------------------------------------------
1162 Note [Implementing tagToEnum#]
1163 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1164 (implement_tagToId arg names) compiles code which takes an argument
1165 'arg', (call it i), and enters the i'th closure in the supplied list
1166 as a consequence. The [Name] is a list of the constructors of this
1167 (enumeration) type.
1168
1169 The code we generate is this:
1170 push arg
1171 push bogus-word
1172
1173 TESTEQ_I 0 L1
1174 PUSH_G <lbl for first data con>
1175 JMP L_Exit
1176
1177 L1: TESTEQ_I 1 L2
1178 PUSH_G <lbl for second data con>
1179 JMP L_Exit
1180 ...etc...
1181 Ln: TESTEQ_I n L_fail
1182 PUSH_G <lbl for last data con>
1183 JMP L_Exit
1184
1185 L_fail: CASEFAIL
1186
1187 L_exit: SLIDE 1 n
1188 ENTER
1189
1190 The 'bogus-word' push is because TESTEQ_I expects the top of the stack
1191 to have an info-table, and the next word to have the value to be
1192 tested. This is very weird, but it's the way it is right now. See
1193 Interpreter.c. We don't acutally need an info-table here; we just
1194 need to have the argument to be one-from-top on the stack, hence pushing
1195 a 1-word null. See Trac #8383.
1196 -}
1197
1198
1199 implement_tagToId :: Word -> Sequel -> BCEnv
1200 -> AnnExpr' Id VarSet -> [Name] -> BcM BCInstrList
1201 -- See Note [Implementing tagToEnum#]
1202 implement_tagToId d s p arg names
1203 = ASSERT( notNull names )
1204 do (push_arg, arg_words) <- pushAtom d p arg
1205 labels <- getLabelsBc (genericLength names)
1206 label_fail <- getLabelBc
1207 label_exit <- getLabelBc
1208 let infos = zip4 labels (tail labels ++ [label_fail])
1209 [0 ..] names
1210 steps = map (mkStep label_exit) infos
1211
1212 return (push_arg
1213 `appOL` unitOL (PUSH_UBX (Left MachNullAddr) 1)
1214 -- Push bogus word (see Note [Implementing tagToEnum#])
1215 `appOL` concatOL steps
1216 `appOL` toOL [ LABEL label_fail, CASEFAIL,
1217 LABEL label_exit ]
1218 `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1)
1219 -- "+1" to account for bogus word
1220 -- (see Note [Implementing tagToEnum#])
1221 `appOL` unitOL ENTER)
1222 where
1223 mkStep l_exit (my_label, next_label, n, name_for_n)
1224 = toOL [LABEL my_label,
1225 TESTEQ_I n next_label,
1226 PUSH_G name_for_n,
1227 JMP l_exit]
1228
1229
1230 -- -----------------------------------------------------------------------------
1231 -- pushAtom
1232
1233 -- Push an atom onto the stack, returning suitable code & number of
1234 -- stack words used.
1235 --
1236 -- The env p must map each variable to the highest- numbered stack
1237 -- slot for it. For example, if the stack has depth 4 and we
1238 -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1239 -- the tag in stack[5], the stack will have depth 6, and p must map v
1240 -- to 5 and not to 4. Stack locations are numbered from zero, so a
1241 -- depth 6 stack has valid words 0 .. 5.
1242
1243 pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
1244
1245 pushAtom d p e
1246 | Just e' <- bcView e
1247 = pushAtom d p e'
1248
1249 pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
1250 = return (nilOL, 0) -- treated just like a variable V
1251
1252 pushAtom d p (AnnVar v)
1253 | UnaryRep rep_ty <- repType (idType v)
1254 , V <- typeArgRep rep_ty
1255 = return (nilOL, 0)
1256
1257 | isFCallId v
1258 = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
1259
1260 | Just primop <- isPrimOpId_maybe v
1261 = return (unitOL (PUSH_PRIMOP primop), 1)
1262
1263 | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
1264 = do dflags <- getDynFlags
1265 let sz :: Word16
1266 sz = fromIntegral (idSizeW dflags v)
1267 l = trunc16 $ d - d_v + fromIntegral sz - 2
1268 return (toOL (genericReplicate sz (PUSH_L l)), sz)
1269 -- d - d_v the number of words between the TOS
1270 -- and the 1st slot of the object
1271 --
1272 -- d - d_v - 1 the offset from the TOS of the 1st slot
1273 --
1274 -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
1275 -- of the object.
1276 --
1277 -- Having found the last slot, we proceed to copy the right number of
1278 -- slots on to the top of the stack.
1279
1280 | otherwise -- v must be a global variable
1281 = do dflags <- getDynFlags
1282 let sz :: Word16
1283 sz = fromIntegral (idSizeW dflags v)
1284 MASSERT(sz == 1)
1285 return (unitOL (PUSH_G (getName v)), sz)
1286
1287
1288 pushAtom _ _ (AnnLit lit) = do
1289 dflags <- getDynFlags
1290 let code rep
1291 = let size_host_words = fromIntegral (argRepSizeW dflags rep)
1292 in return (unitOL (PUSH_UBX (Left lit) size_host_words),
1293 size_host_words)
1294
1295 case lit of
1296 MachLabel _ _ _ -> code N
1297 MachWord _ -> code N
1298 MachInt _ -> code N
1299 MachWord64 _ -> code L
1300 MachInt64 _ -> code L
1301 MachFloat _ -> code F
1302 MachDouble _ -> code D
1303 MachChar _ -> code N
1304 MachNullAddr -> code N
1305 MachStr s -> pushStr s
1306 -- No LitInteger's should be left by the time this is called.
1307 -- CorePrep should have converted them all to a real core
1308 -- representation.
1309 LitInteger {} -> panic "pushAtom: LitInteger"
1310 where
1311 pushStr s
1312 = let getMallocvilleAddr
1313 =
1314 -- we could grab the Ptr from the ForeignPtr,
1315 -- but then we have no way to control its lifetime.
1316 -- In reality it'll probably stay alive long enoungh
1317 -- by virtue of the global FastString table, but
1318 -- to be on the safe side we copy the string into
1319 -- a malloc'd area of memory.
1320 do let n = BS.length s
1321 ptr <- ioToBc (mallocBytes (n+1))
1322 recordMallocBc ptr
1323 ioToBc (
1324 BS.unsafeUseAsCString s $ \p -> do
1325 memcpy ptr p (fromIntegral n)
1326 pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
1327 return ptr
1328 )
1329 in do
1330 addr <- getMallocvilleAddr
1331 -- Get the addr on the stack, untaggedly
1332 return (unitOL (PUSH_UBX (Right addr) 1), 1)
1333
1334 pushAtom _ _ expr
1335 = pprPanic "ByteCodeGen.pushAtom"
1336 (pprCoreExpr (deAnnotate (undefined, expr)))
1337
1338 foreign import ccall unsafe "memcpy"
1339 memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
1340
1341
1342 -- -----------------------------------------------------------------------------
1343 -- Given a bunch of alts code and their discrs, do the donkey work
1344 -- of making a multiway branch using a switch tree.
1345 -- What a load of hassle!
1346
1347 mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
1348 -- a hint; generates better code
1349 -- Nothing is always safe
1350 -> [(Discr, BCInstrList)]
1351 -> BcM BCInstrList
1352 mkMultiBranch maybe_ncons raw_ways = do
1353 lbl_default <- getLabelBc
1354
1355 let
1356 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1357 mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))
1358 -- shouldn't happen?
1359
1360 mkTree [val] range_lo range_hi
1361 | range_lo == range_hi
1362 = return (snd val)
1363 | null defaults -- Note [CASEFAIL]
1364 = do lbl <- getLabelBc
1365 return (testEQ (fst val) lbl
1366 `consOL` (snd val
1367 `appOL` (LABEL lbl `consOL` unitOL CASEFAIL)))
1368 | otherwise
1369 = return (testEQ (fst val) lbl_default `consOL` snd val)
1370
1371 -- Note [CASEFAIL] It may be that this case has no default
1372 -- branch, but the alternatives are not exhaustive - this
1373 -- happens for GADT cases for example, where the types
1374 -- prove that certain branches are impossible. We could
1375 -- just assume that the other cases won't occur, but if
1376 -- this assumption was wrong (because of a bug in GHC)
1377 -- then the result would be a segfault. So instead we
1378 -- emit an explicit test and a CASEFAIL instruction that
1379 -- causes the interpreter to barf() if it is ever
1380 -- executed.
1381
1382 mkTree vals range_lo range_hi
1383 = let n = length vals `div` 2
1384 vals_lo = take n vals
1385 vals_hi = drop n vals
1386 v_mid = fst (head vals_hi)
1387 in do
1388 label_geq <- getLabelBc
1389 code_lo <- mkTree vals_lo range_lo (dec v_mid)
1390 code_hi <- mkTree vals_hi v_mid range_hi
1391 return (testLT v_mid label_geq
1392 `consOL` (code_lo
1393 `appOL` unitOL (LABEL label_geq)
1394 `appOL` code_hi))
1395
1396 the_default
1397 = case defaults of
1398 [] -> nilOL
1399 [(_, def)] -> LABEL lbl_default `consOL` def
1400 _ -> panic "mkMultiBranch/the_default"
1401 instrs <- mkTree notd_ways init_lo init_hi
1402 return (instrs `appOL` the_default)
1403 where
1404 (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
1405 notd_ways = sortBy (comparing fst) not_defaults
1406
1407 testLT (DiscrI i) fail_label = TESTLT_I i fail_label
1408 testLT (DiscrW i) fail_label = TESTLT_W i fail_label
1409 testLT (DiscrF i) fail_label = TESTLT_F i fail_label
1410 testLT (DiscrD i) fail_label = TESTLT_D i fail_label
1411 testLT (DiscrP i) fail_label = TESTLT_P i fail_label
1412 testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
1413
1414 testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
1415 testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
1416 testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
1417 testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
1418 testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
1419 testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr"
1420
1421 -- None of these will be needed if there are no non-default alts
1422 (init_lo, init_hi)
1423 | null notd_ways
1424 = panic "mkMultiBranch: awesome foursome"
1425 | otherwise
1426 = case fst (head notd_ways) of
1427 DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
1428 DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
1429 DiscrF _ -> ( DiscrF minF, DiscrF maxF )
1430 DiscrD _ -> ( DiscrD minD, DiscrD maxD )
1431 DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
1432 NoDiscr -> panic "mkMultiBranch NoDiscr"
1433
1434 (algMinBound, algMaxBound)
1435 = case maybe_ncons of
1436 -- XXX What happens when n == 0?
1437 Just n -> (0, fromIntegral n - 1)
1438 Nothing -> (minBound, maxBound)
1439
1440 isNoDiscr NoDiscr = True
1441 isNoDiscr _ = False
1442
1443 dec (DiscrI i) = DiscrI (i-1)
1444 dec (DiscrW w) = DiscrW (w-1)
1445 dec (DiscrP i) = DiscrP (i-1)
1446 dec other = other -- not really right, but if you
1447 -- do cases on floating values, you'll get what you deserve
1448
1449 -- same snotty comment applies to the following
1450 minF, maxF :: Float
1451 minD, maxD :: Double
1452 minF = -1.0e37
1453 maxF = 1.0e37
1454 minD = -1.0e308
1455 maxD = 1.0e308
1456
1457
1458 -- -----------------------------------------------------------------------------
1459 -- Supporting junk for the compilation schemes
1460
1461 -- Describes case alts
1462 data Discr
1463 = DiscrI Int
1464 | DiscrW Word
1465 | DiscrF Float
1466 | DiscrD Double
1467 | DiscrP Word16
1468 | NoDiscr
1469 deriving (Eq, Ord)
1470
1471 instance Outputable Discr where
1472 ppr (DiscrI i) = int i
1473 ppr (DiscrW w) = text (show w)
1474 ppr (DiscrF f) = text (show f)
1475 ppr (DiscrD d) = text (show d)
1476 ppr (DiscrP i) = ppr i
1477 ppr NoDiscr = text "DEF"
1478
1479
1480 lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
1481 lookupBCEnv_maybe = Map.lookup
1482
1483 idSizeW :: DynFlags -> Id -> Int
1484 idSizeW dflags = argRepSizeW dflags . bcIdArgRep
1485
1486 bcIdArgRep :: Id -> ArgRep
1487 bcIdArgRep = toArgRep . bcIdPrimRep
1488
1489 bcIdPrimRep :: Id -> PrimRep
1490 bcIdPrimRep = typePrimRep . bcIdUnaryType
1491
1492 isFollowableArg :: ArgRep -> Bool
1493 isFollowableArg P = True
1494 isFollowableArg _ = False
1495
1496 isVoidArg :: ArgRep -> Bool
1497 isVoidArg V = True
1498 isVoidArg _ = False
1499
1500 bcIdUnaryType :: Id -> UnaryType
1501 bcIdUnaryType x = case repType (idType x) of
1502 UnaryRep rep_ty -> rep_ty
1503 UbxTupleRep [rep_ty] -> rep_ty
1504 UbxTupleRep [rep_ty1, rep_ty2]
1505 | VoidRep <- typePrimRep rep_ty1 -> rep_ty2
1506 | VoidRep <- typePrimRep rep_ty2 -> rep_ty1
1507 _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x))
1508
1509 -- See bug #1257
1510 unboxedTupleException :: a
1511 unboxedTupleException
1512 = throwGhcException
1513 (ProgramError
1514 ("Error: bytecode compiler can't handle unboxed tuples.\n"++
1515 " Possibly due to foreign import/export decls in source.\n"++
1516 " Workaround: use -fobject-code, or compile this module to .o separately."))
1517
1518
1519 mkSLIDE :: Word16 -> Word -> OrdList BCInstr
1520 mkSLIDE n d
1521 -- if the amount to slide doesn't fit in a word,
1522 -- generate multiple slide instructions
1523 | d > fromIntegral limit
1524 = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
1525 | d == 0
1526 = nilOL
1527 | otherwise
1528 = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
1529 where
1530 limit :: Word16
1531 limit = maxBound
1532
1533 splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
1534 -- The arguments are returned in *right-to-left* order
1535 splitApp e | Just e' <- bcView e = splitApp e'
1536 splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
1537 (f', as) -> (f', a:as)
1538 splitApp e = (e, [])
1539
1540
1541 bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
1542 -- The "bytecode view" of a term discards
1543 -- a) type abstractions
1544 -- b) type applications
1545 -- c) casts
1546 -- d) ticks (but not breakpoints)
1547 -- Type lambdas *can* occur in random expressions,
1548 -- whereas value lambdas cannot; that is why they are nuked here
1549 bcView (AnnCast (_,e) _) = Just e
1550 bcView (AnnLam v (_,e)) | isTyVar v = Just e
1551 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
1552 bcView (AnnTick Breakpoint{} _) = Nothing
1553 bcView (AnnTick _other_tick (_,e)) = Just e
1554 bcView _ = Nothing
1555
1556 isVAtom :: AnnExpr' Var ann -> Bool
1557 isVAtom e | Just e' <- bcView e = isVAtom e'
1558 isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
1559 isVAtom (AnnCoercion {}) = True
1560 isVAtom _ = False
1561
1562 atomPrimRep :: AnnExpr' Id ann -> PrimRep
1563 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
1564 atomPrimRep (AnnVar v) = bcIdPrimRep v
1565 atomPrimRep (AnnLit l) = typePrimRep (literalType l)
1566 atomPrimRep (AnnCoercion {}) = VoidRep
1567 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
1568
1569 atomRep :: AnnExpr' Id ann -> ArgRep
1570 atomRep e = toArgRep (atomPrimRep e)
1571
1572 isPtrAtom :: AnnExpr' Id ann -> Bool
1573 isPtrAtom e = isFollowableArg (atomRep e)
1574
1575 -- Let szsw be the sizes in words of some items pushed onto the stack,
1576 -- which has initial depth d'. Return the values which the stack environment
1577 -- should map these items to.
1578 mkStackOffsets :: Word -> [Word] -> [Word]
1579 mkStackOffsets original_depth szsw
1580 = map (subtract 1) (tail (scanl (+) original_depth szsw))
1581
1582 typeArgRep :: Type -> ArgRep
1583 typeArgRep = toArgRep . typePrimRep
1584
1585 -- -----------------------------------------------------------------------------
1586 -- The bytecode generator's monad
1587
1588 type BcPtr = Either ItblPtr (Ptr ())
1589
1590 data BcM_State
1591 = BcM_State
1592 { bcm_dflags :: DynFlags
1593 , uniqSupply :: UniqSupply -- for generating fresh variable names
1594 , thisModule :: Module -- current module (for breakpoints)
1595 , nextlabel :: Word16 -- for generating local labels
1596 , malloced :: [BcPtr] -- thunks malloced for current BCO
1597 -- Should be free()d when it is GCd
1598 , breakArray :: BreakArray -- array of breakpoint flags
1599 }
1600
1601 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
1602
1603 ioToBc :: IO a -> BcM a
1604 ioToBc io = BcM $ \st -> do
1605 x <- io
1606 return (st, x)
1607
1608 runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r
1609 -> IO (BcM_State, r)
1610 runBc dflags us this_mod modBreaks (BcM m)
1611 = m (BcM_State dflags us this_mod 0 [] breakArray)
1612 where
1613 breakArray = modBreaks_flags modBreaks
1614
1615 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1616 thenBc (BcM expr) cont = BcM $ \st0 -> do
1617 (st1, q) <- expr st0
1618 let BcM k = cont q
1619 (st2, r) <- k st1
1620 return (st2, r)
1621
1622 thenBc_ :: BcM a -> BcM b -> BcM b
1623 thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
1624 (st1, _) <- expr st0
1625 (st2, r) <- cont st1
1626 return (st2, r)
1627
1628 returnBc :: a -> BcM a
1629 returnBc result = BcM $ \st -> (return (st, result))
1630
1631 instance Functor BcM where
1632 fmap = liftM
1633
1634 instance Applicative BcM where
1635 pure = return
1636 (<*>) = ap
1637
1638 instance Monad BcM where
1639 (>>=) = thenBc
1640 (>>) = thenBc_
1641 return = returnBc
1642
1643 instance HasDynFlags BcM where
1644 getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
1645
1646 emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
1647 emitBc bco
1648 = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
1649
1650 recordMallocBc :: Ptr a -> BcM ()
1651 recordMallocBc a
1652 = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
1653
1654 recordItblMallocBc :: ItblPtr -> BcM ()
1655 recordItblMallocBc a
1656 = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
1657
1658 getLabelBc :: BcM Word16
1659 getLabelBc
1660 = BcM $ \st -> do let nl = nextlabel st
1661 when (nl == maxBound) $
1662 panic "getLabelBc: Ran out of labels"
1663 return (st{nextlabel = nl + 1}, nl)
1664
1665 getLabelsBc :: Word16 -> BcM [Word16]
1666 getLabelsBc n
1667 = BcM $ \st -> let ctr = nextlabel st
1668 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1669
1670 getBreakArray :: BcM BreakArray
1671 getBreakArray = BcM $ \st -> return (st, breakArray st)
1672
1673 newUnique :: BcM Unique
1674 newUnique = BcM $
1675 \st -> case takeUniqFromSupply (uniqSupply st) of
1676 (uniq, us) -> let newState = st { uniqSupply = us }
1677 in return (newState, uniq)
1678
1679 getCurrentModule :: BcM Module
1680 getCurrentModule = BcM $ \st -> return (st, thisModule st)
1681
1682 newId :: Type -> BcM Id
1683 newId ty = do
1684 uniq <- newUnique
1685 return $ mkSysLocal tickFS uniq ty
1686
1687 tickFS :: FastString
1688 tickFS = fsLit "ticked"