WARNING! Access to this system is limited to authorised users only.
Unauthorised users may be subject to prosecution.
Unauthorised access to this system is a criminal offence under Australian law (Federal Crimes Act 1914 Part VIA)
It is a criminal offence to:
(1) Obtain access to data without authority. -Penalty 2 years imprisonment.
(2) Damage, delete, alter or insert data without authority. -Penalty 10 years imprisonment.
User activity is monitored and recorded. Anyone using this system expressly consents to such monitoring and recording.

To protect your data, the CISO officer has suggested users to enable 2FA as soon as possible.
Currently 2.4% of users enabled 2FA.

CodeGen.hs 19.5 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12
-- |
-- Module      :  Compiler.Mu.CodeGen
-- Copyright   :  nathyong 2016
-- License     :  BSD3
--
-- Maintainer  :  nathyong@gmail.com
-- Stability   :  experimental
-- Portability :  unknown
--
-- Utility functions for Haskell code generation via Mu.
--

nathyong's avatar
nathyong committed
13 14
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
15
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16
{-# LANGUAGE OverloadedStrings #-}
17

18 19 20 21 22
module Compiler.Mu.CodeGen
  ( -- * Mu Monad
    Mu
  , runMu
  , definitions
23
  , topLevels
24
  , MuResult
25 26
  , MuMergedResult
  , mergeResults
27 28
    -- * Block building monad
  , Blocks
nathyong's avatar
nathyong committed
29 30 31 32 33
  , CapturedIDs
  , sortedIDs
  , sortedIDNames
  , BasicBlocks
  , ExpWriter
34
  , runBlocks
nathyong's avatar
nathyong committed
35 36
  , capturing
  , lookupID
37
  , basicBlock
nathyong's avatar
nathyong committed
38
  , paramsFor
39
  , assign
40
  , emit
nathyong's avatar
nathyong committed
41
  , emitBB
42
  , upTag
nathyong's avatar
nathyong committed
43
  , upConstant 
44
  , upValue
nathyong's avatar
nathyong committed
45
    -- * Code generation
46
  , UnboxedData (..)
47
  , bundleMu
48
  , populate
49
    -- * Mu interface
nathyong's avatar
nathyong committed
50 51
  , typedef
  , constant
52 53
  , funcsig
  , funcdef
54
  , primfuncdef
55 56
  , closure
  , string
57 58
    -- * Naming interface
  , dataConEntry
59 60 61 62 63 64 65 66
  , closureNameOf
  , entryNameOf
    -- * Type names
  , loadTypes
  , i64
  , i8
  , muString
    -- * STG Closures in Mu
67
  , closureTR
68 69
  , muClosure
  , muClosureRef
70 71
  , muClosureMetadata
  , muClosureTag
72 73 74
  , muClosureFunction
  , muClosureFunctionSig
  , haskellData
75
  , getClosureField
76
  , getClosureData
77
  , ClosureField (..)
nathyong's avatar
nathyong committed
78 79
    -- * Utility functions
  , isInternal
80 81
) where

82
import Control.Applicative ((<|>))
83
import Control.Monad.IO.Class (MonadIO, liftIO)
nathyong's avatar
nathyong committed
84 85 86
import Control.Monad.Reader (Reader, ReaderT, MonadReader, runReaderT, ask, local, reader)
import Control.Monad.State.Strict (State, StateT, MonadState, evalState, runStateT, gets)
import Control.Monad.Trans (MonadTrans, lift)
87
import Control.Monad.Writer (Writer, WriterT, MonadWriter, runWriterT, tell)
88
import Data.Binary (Binary)
89
import Data.Foldable (toList, foldl')
90
import Data.List (genericLength)
91
import Data.Map.Strict (Map)
92 93 94 95
import Data.Monoid ((<>))
import Data.Sequence (Seq, (|>))
import Data.String (fromString)
import GHC.Generics (Generic)
96
import qualified Data.ByteString as B
nathyong's avatar
nathyong committed
97
import qualified Data.Sequence as S
98
import qualified Data.Map.Strict as M
99 100
import qualified Foreign as F
import qualified Foreign.C as C
101

nathyong's avatar
nathyong committed
102 103
import Language.Haskell.GHC.Simple (ModMetadata(..), mmSummary)
import           Lens.Micro.Platform ((%=), Lens')
104

105
import           FastString (fsLit, zEncodeFS, zString)
106
import qualified GHC
107
import           Name (NamedThing (..), nameStableString, isSystemName, isInternalName)
108
import           Unique (Uniquable (..))
109

110 111 112
import           Mu.API
import           Mu.AST
import           Mu.Interface
113

114
import Debug.Trace
115

116
-------------------------------------------------- * Data types
117

118 119 120 121 122 123 124
-- | Top-level constructs which need to be allocated and populated in the Mu
-- separately.
data TopLevel = Closure GlobalCellName [UnboxedData] FunctionName
              | ByteArray GlobalCellName B.ByteString
    deriving (Generic)

instance Binary TopLevel
125

126 127 128 129 130
instance HasName TopLevel where
    toName tl = toName $ case tl of
        Closure n _ _ -> n
        ByteArray n _ -> n

131 132 133
data UnboxedData = UnboxedInt Integer
                 | UnboxedDouble Rational
                 | TaggedPointer GlobalCellName Int
nathyong's avatar
nathyong committed
134
                 | NullPointer
135 136
    deriving (Generic)

137
instance Binary UnboxedData
138

139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
type MuResult = (Seq Definition, Seq TopLevel, Maybe FunctionName)
type MuMergedResult = ( Map Name Definition
                      , Map Name TopLevel
                      , Maybe FunctionName)

mergeResults :: [MuResult] -> MuMergedResult
mergeResults = foldl' mergeResults' (M.empty, M.empty, Nothing)
  where
    mergeResults' :: MuMergedResult -> MuResult -> MuMergedResult
    mergeResults' (defmap, topmap, fn) (defs, tops, fn') =
        ( foldl' insert defmap defs
        , foldl' insert topmap tops
        , fn <|> fn')
      where
        insert m n = M.insert (toName n) n m
154 155 156 157 158 159

-------------------------------------------------- * Mu Monad

newtype Mu a = Mu (State MuState a)
    deriving (Functor, Applicative, Monad, MonadState MuState)

160
-- | Run a Mu computation from the empty state, storing the result.
nathyong's avatar
nathyong committed
161 162
runMu :: MuState -> Mu a -> a
runMu state (Mu code) = evalState code state
163 164

data MuState = MuState
165
    { _uniqueID :: !Int
nathyong's avatar
nathyong committed
166
    , _moduleName :: String
167 168
    , _definitions :: Seq Definition
    , _topLevels :: Seq TopLevel
169 170
    }

nathyong's avatar
nathyong committed
171 172 173 174 175 176 177 178 179 180 181
uniqueID :: Lens' MuState Int
uniqueID k m = fmap (\new -> m { _uniqueID = new }) (k (_uniqueID m))

moduleName :: Lens' MuState String
moduleName k m = fmap (\new -> m { _moduleName = new }) (k (_moduleName m))

definitions :: Lens' MuState (Seq Definition)
definitions k m = fmap (\new -> m { _definitions = new }) (k (_definitions m))

topLevels :: Lens' MuState (Seq TopLevel)
topLevels k m = fmap (\new -> m { _topLevels = new }) (k (_topLevels m))
182 183 184

-------------------------------------------------- * Block building monad

nathyong's avatar
nathyong committed
185 186 187 188 189 190 191 192
-- | Read only state for building blocks.
type CapturedIDs = Map GHC.Id VarName

sortedIDs :: CapturedIDs -> [GHC.Id]
sortedIDs mapping = fmap fst $ M.toAscList mapping

-- | Mutable state for the block building monad
type BasicBlocks = Seq BasicBlock
193

nathyong's avatar
nathyong committed
194 195
-- | An environment for outputing individual instructions.
type ExpWriter = WriterT [Assigned Expression] Blocks
196 197


nathyong's avatar
nathyong committed
198 199 200 201 202
-- | A monad for all of the state involved when building a function.  This
-- includes the basic blocks and their instructions, as well as the captured
-- variables inside a particular function.
newtype Blocks a = Blocks (ReaderT CapturedIDs (WriterT BasicBlocks Mu) a)
    deriving (Functor, Applicative, Monad, MonadWriter BasicBlocks, MonadReader CapturedIDs)
203 204


nathyong's avatar
nathyong committed
205 206 207 208 209
runBlocks :: CapturedIDs -> Blocks a -> Mu (a, BasicBlocks)
runBlocks r (Blocks code) = do
    (a, bbs) <- runWriterT (runReaderT code r)
    traceShowM $ ("There are ", S.length bbs, " basic blocks")
    return (a, bbs)
nathyong's avatar
nathyong committed
210

211

nathyong's avatar
nathyong committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
-- | Run a 'Blocks' computation inside a local environment capturing extra
-- variables.
capturing :: MonadReader CapturedIDs m
          => m a  -- ^ Computation to run
          -> Map GHC.Id VarName  -- ^ Extra variables to capture
          -> m a
capturing b r = local (M.union r) b


sortedIDNames :: MonadReader CapturedIDs m => m [VarName]
sortedIDNames = ask >>= return . fmap snd . M.toAscList


-- | Obtain the 'VarName' for a particular 'GHC.Id' in the current mapping.  If
-- it does not exist, crash and burn spectacularly.
lookupID :: GHC.Id -> ExpWriter VarName
lookupID i = lift $ do
    n <- reader (M.lookup i)
    case n of
        Nothing -> error ("lookupID: could not find " ++ stringify i)
        Just n' -> return n'


-- | Lift a 'Mu' computation into the 'Blocks' monad.
236
liftBlocks :: Mu a -> Blocks a
nathyong's avatar
nathyong committed
237
liftBlocks m = Blocks (lift . lift $ m)
238 239 240 241


-- | Emit a basic block without an exceptional parameter.
basicBlock
nathyong's avatar
nathyong committed
242 243 244
    :: BasicBlockName  -- ^ Name of the block itself
    -> [(VarName, TypedefName)]  -- ^ Parameters of the block, and their types
    -> ExpWriter Expression  -- ^ Code to generate expressions within the block
245 246
    -> Blocks BasicBlock
basicBlock n params exprs = do
nathyong's avatar
nathyong committed
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
    bindings <- ask
    (terminator, body) <- runWriterT exprs `capturing` newMappings n bindings
    return $ BasicBlock n (params ++ paramsFor n bindings) Nothing body terminator


-- | Generate a new mapping for 
newMappings :: BasicBlockName
            -> Map GHC.Id a
            -> CapturedIDs
newMappings block mapping = M.mapWithKey genParam mapping
  where
    genParam i _ = block `dot` tail (stringify i)


-- | Obtain a list of variables and their types
paramsFor :: BasicBlockName
          -> Map GHC.Id a
          -> [(VarName, TypedefName)]
paramsFor block mapping = fmap pairUp (M.toAscList mapping)
266
  where
nathyong's avatar
nathyong committed
267
    pairUp (i, _) = (block `dot` tail (stringify i), haskellData)
268 269 270


-- | Assign the result of a Mu 'Expression' to a 'VarName'.
nathyong's avatar
nathyong committed
271
assign :: Expression -> ExpWriter VarName
272 273
assign expr = do
    uid <- lift $ liftBlocks nextMuUnique
nathyong's avatar
nathyong committed
274 275
    let n = fromString ("@var" ++ uid)
    emit' $ [n] := expr
276 277 278
    return n


279
-- | Run a Mu 'Expression' without binding to anything.
nathyong's avatar
nathyong committed
280 281 282 283 284 285 286 287 288 289
emit :: Expression -> ExpWriter ()
emit expr = emit' $ [] := expr


emit' :: Assigned Expression -> ExpWriter ()
emit' = tell . pure


emitBB :: BasicBlock -> Blocks ()
emitBB = tell . pure
290 291 292 293


-- | Declare a (constant) tag to be defined at the top level, without
-- clobbering any other upvalues.
nathyong's avatar
nathyong committed
294
upTag :: Int -> ExpWriter VarName
295 296 297 298 299 300
upTag i = lift . liftBlocks $ do
    let n = fromString ("@tag_const_" ++ show i)
    constant n muClosureTag (IntCtor (fromIntegral i))
    return (VarName $ toName n)


nathyong's avatar
nathyong committed
301 302 303 304 305 306 307 308 309
-- | Declare an integer constant to be defined at the top level, without
-- clobbering any other upvalues.
upConstant :: Int -> ExpWriter VarName
upConstant i = lift . liftBlocks $ do
    let n = fromString ("@i64_" ++ show i)
    constant n i64 (IntCtor (fromIntegral i))
    return (VarName $ toName n)


310
-- | Declare a (constant) value to be defined at the top level.
nathyong's avatar
nathyong committed
311
upValue :: ConstConstructor -> TypedefName -> ExpWriter VarName
312 313
upValue ctor ty = lift . liftBlocks $ do
    uid <- nextMuUnique
nathyong's avatar
nathyong committed
314
    let n = fromString ("@upvar" ++ uid)
315
    constant n ty ctor
316
    return (VarName $ toName n)
317 318


319 320
-------------------------------------------------- * Code generation

321
-- | Extract the definitions and other useful things from the Mu monad.
nathyong's avatar
nathyong committed
322 323
bundleMu :: String -> Mu () -> MuResult
bundleMu modName codegen = runMu initialState $ do
324 325
    codegen
    defns <- gets _definitions
326
    tops <- gets _topLevels
327
    return (defns, tops, Nothing)
nathyong's avatar
nathyong committed
328 329
  where
    initialState = MuState 0 modName mempty mempty
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345


-- | Populate a Mu Closure, or other top-level data type, at build-time.
-- Assumes that all the objects in a bundle will have been imported already.
populate :: MonadIO m => F.Ptr MuCtx -> TopLevel -> m ()
populate ctx top = case top of
    Closure n payload entry -> do
        -- allocate the closure
        closureLength <- handleFromSint64 ctx (genericLength payload) 64
        closureType <- getID ctx muClosure
        closureRef <- newHybrid ctx closureType closureLength

        -- populate the closure
        closureIref <- getIref ctx closureRef
        one <- handleFromSint64 ctx 1 52

346
        closureEntryRef <- getFieldIref ctx closureIref (fieldIx EntryField)
347 348 349
        entryRef <- getID ctx entry >>= handleFromFunc ctx
        store ctx muOrdNotAtomic closureEntryRef entryRef

350 351 352 353 354 355
        closureLengthRef <- getFieldIref ctx closureIref (fieldIx NArgsField)
        store ctx muOrdNotAtomic closureLengthRef closureLength

        closureTagRef <- getFieldIref ctx closureIref (fieldIx TagField)
        store ctx muOrdNotAtomic closureTagRef one

356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
        closureDataRef <- getVarPartIref ctx closureIref
        let storePayloads datums ref = case datums of
                [] -> return ()
                d:ds -> do
                    case d of
                        UnboxedInt i -> do
                            val <- handleFromSint64 ctx (fromIntegral i) 52
                            trVal <- tr64FromInt ctx val
                            store ctx muOrdNotAtomic ref trVal
                        UnboxedDouble r -> do
                            val <- handleFromDouble ctx (fromRational r)
                            trVal <- tr64FromFp ctx val
                            store ctx muOrdNotAtomic ref trVal
                        TaggedPointer cell tag -> do
                            tag' <- handleFromSint64 ctx (fromIntegral tag) 6
                            cellID <- getID ctx cell
                            cellHandle <- handleFromGlobal ctx cellID
                            cellRef <- ctxLoad ctx muOrdNotAtomic cellHandle
                            trCellRef <- tr64FromRef ctx cellRef tag'
                            store ctx muOrdNotAtomic ref trCellRef
nathyong's avatar
nathyong committed
376 377 378 379 380 381 382
                        NullPointer -> do
                            tag' <- handleFromSint64 ctx 0 6
                            reftyID <- getID ctx muClosureRef
                            nullRef <- handleFromPtr ctx reftyID F.nullPtr
                            trNull <- tr64FromRef ctx nullRef tag'
                            store ctx muOrdNotAtomic ref trNull

383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405
                    shiftIref ctx ref one >>= storePayloads ds

        storePayloads payload closureDataRef

        -- attach it to the global cell
        cell <- handleFromGlobal ctx =<< getID ctx n
        store ctx muOrdNotAtomic cell closureRef

    ByteArray n bs -> do
        -- allocate the byte array
        arrLength <- handleFromSint64 ctx (fromIntegral (B.length bs)) 64
        arrType <- getID ctx muString
        arrRef <- newHybrid ctx arrType arrLength

        -- populate the array
        ptr <- pin ctx arrRef >>= handleToPtr ctx 
        liftIO $ B.useAsCStringLen bs $ \(strptr, strlen) -> do
            F.copyBytes (F.castPtr ptr :: C.CString) strptr strlen
        unpin ctx arrRef

        -- attach it to the global cell
        cell <- handleFromGlobal ctx =<< getID ctx n
        store ctx muOrdNotAtomic cell arrRef
406 407


408
-------------------------------------------------- * Mu interface
409

nathyong's avatar
nathyong committed
410 411
-- | Get a unique identifier (name) from the Mu monad.
nextMuUnique :: Mu String
412 413
nextMuUnique = do
    currentID <- gets _uniqueID
nathyong's avatar
nathyong committed
414
    modName <- gets _moduleName
415
    uniqueID %= (+1)
nathyong's avatar
nathyong committed
416
    return $ "_uq_" <> modName <> "_" <> show currentID
417

418 419
-- | Emit a closure with a payload and an entry function.  The closure itself
-- will be allocated during build time.
420 421
closure :: (Uniquable a, NamedThing a)
        => a -> [UnboxedData] -> Mu FunctionName -> Mu ()
422
closure name payload code = do
423
    func_name <- code
424 425 426 427
    topLevels %= (|> Closure name' payload func_name)
    definitions %= (|> GlobalCell name' muClosureRef)
  where
    name' = closureNameOf name
428 429


430 431 432 433
-- | Emit a string.  The string itself will be allocated during build time.
string :: GHC.Id -> B.ByteString -> Mu GlobalCellName
string name bytes = do
    name' <- do
434
        uid <- nextMuUnique
nathyong's avatar
nathyong committed
435
        return $ fromString $ stringify name <> uid <> "_str"
436 437 438 439 440 441
    definitions %= (|> GlobalCell name' muStringRef)
    topLevels %= (|> ByteArray name' bytes)
    return name'


-- | Emit a type definition.
442 443 444 445
typedef :: TypedefName -> Type -> Mu ()
typedef n ty = definitions %= (|> TypeDefinition n ty)


446
-- | Emit a constant definition.
447 448 449 450
constant :: ConstantName -> TypedefName -> ConstConstructor -> Mu ()
constant n ty ctor = definitions %= (|> Constant n ty ctor)


451
-- | Emit a function signature definition.
452 453
funcsig :: SignatureName -> [TypedefName] -> [TypedefName] -> Mu ()
funcsig n argtys rettys = definitions %= (|> SignatureDefinition n argtys rettys)
454

nathyong's avatar
nathyong committed
455

456
-- | Emit a function (version) definition.
457 458
funcdef :: FunctionName -> Version -> SignatureName -> Blocks BasicBlock -> Mu ()
funcdef n v sig body = do
nathyong's avatar
nathyong committed
459 460 461
    (entry, bblocks) <- runBlocks M.empty body
    traceBB entry
    mapM_ traceBB bblocks
462
    definitions %= (|> FunctionDefinition n v sig entry (toList bblocks))
nathyong's avatar
nathyong committed
463

464

nathyong's avatar
nathyong committed
465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509
traceBB :: Applicative m => BasicBlock -> m ()
traceBB bb@(BasicBlock n ps exc insts term) = traceShowM (n, fmap sexp' insts, sexp term)
  where
    sexp' :: Assigned Expression -> String
    sexp' (d := aexp) = show d ++ " := " ++ sexp aexp
    sexp :: Expression -> String
    sexp aexp = case aexp of
        BinaryOperation {} -> "BinaryOperation"
        CompareOperation {} -> "CompareOperation"
        ConvertOperation {} -> "ConvertOperation"
        AtomicRMWOperation {} -> "AtomicRMWOperation"
        CmpXchg {} -> "CmpXchg"
        Fence {} -> "Fence"
        New {} -> "New"
        NewHybrid {} -> "NewHybrid"
        Alloca {} -> "Alloca"
        AllocaHybrid {} -> "AllocaHybrid"
        Return {} -> "Return"
        Throw {} -> "Throw"
        Call {} -> "Call"
        CCall {} -> "CCall"
        TailCall {} -> "TailCall"
        Branch1 {} -> "Branch1"
        Branch2 {} -> "Branch2"
        WatchPoint {} -> "WatchPoint"
        Trap {} -> "Trap"
        WPBranch {} -> "WPBranch"
        Switch {} -> "Switch"
        SwapStack {} -> "SwapStack"
        NewThread {} -> "NewThread"
        Comminst {} -> "Comminst"
        Load {} -> "Load"
        Store {} -> "Store"
        ExtractValue {} -> "ExtractValue"
        InsertValue {} -> "InsertValue"
        ExtractElement {} -> "ExtractElement"
        InsertElement {} -> "InsertElement"
        ShuffleVector {} -> "ShuffleVector"
        GetIRef {} -> "GetIRef"
        GetFieldIRef {} -> "GetFieldIRef"
        GetElemIRef {} -> "GetElemIRef"
        ShiftIRef {} -> "ShiftIRef"
        GetVarPartIRef {} -> "GetVarPartIRef"


510 511
primfuncdef :: FunctionName -> Blocks BasicBlock -> Mu ()
primfuncdef n body = funcdef n (Version "1") muClosureFunctionSig body
512

513 514 515 516 517

-------------------------------------------------- * Naming interface

stringify :: (Uniquable a, NamedThing a) => a -> String
stringify a
nathyong's avatar
nathyong committed
518 519
    | isSystemName name || isInternalName name =
        '@':(stableName name <> "_" <> uniquePart a)
520
    | otherwise = '@':(stableName name)
521
  where
522 523
    name = getName a
    stableName = zString . zEncodeFS . fsLit . nameStableString
524 525
    uniquePart = show . getUnique

526 527 528
dataConEntry :: GHC.DataCon -> FunctionName
dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry"

529
closureNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
530
closureNameOf n = GlobalCellName $ Name $ stringify n <> "_closure"
531 532

entryNameOf :: GHC.Id -> FunctionName
533
entryNameOf n = FunctionName $ Name $ stringify n <> "_entry"
534 535 536 537 538 539 540 541


-------------------------------------------------- * Type names

-- | Load a bunch of useful types into the current bundle.  The order of the
-- definitions is arbitrary.
loadTypes :: Mu ()
loadTypes = do
542
    funcsig muClosureFunctionSig [closureTR] [closureTR]
543
    typedef haskellData TagRef64
544
    typedef closureTR TagRef64
545 546 547 548 549
    typedef i64 $ MuInt 64
    constant i64_1 i64 (IntCtor 1)
    typedef i8 $ MuInt 8
    typedef muString $ Hybrid [] i8
    typedef muStringRef $ Ref muString
550
    typedef muClosureMetadata $ MuInt 8
551
    typedef muClosureTag $ MuInt 6
552
    typedef muClosureFunction $ FuncRef muClosureFunctionSig
553 554 555
    typedef muClosure $
        Hybrid [muClosureFunction, muClosureMetadata, muClosureMetadata]
               haskellData
556 557 558 559 560 561 562 563 564 565 566 567 568 569 570
    typedef muClosureRef $ Ref muClosure

i64 :: TypedefName
i64 = "@i64"
i64_1 :: ConstantName
i64_1 = "@i64_1"
i8 :: TypedefName
i8 = "@i8"
muString :: TypedefName
muString = "@string_t"
muStringRef :: TypedefName
muStringRef = "@string_t_ref"

-------------------------------------------------- * STG Closures in Mu

571 572 573 574 575 576 577 578 579
-- | A tagged reference to a closure.
closureTR :: TypedefName
closureTR = "@_closure_tagref"

-- | A short field used to store things like the number of elements and the
-- partial-application status of the function. 
muClosureMetadata :: TypedefName
muClosureMetadata = "@_closure_metadata"

580 581 582 583
-- | A tag that can be put on the end of a tagged reference.
muClosureTag :: TypedefName
muClosureTag = "@_closure_tag"

584
-- | The Mu closure itself.
585 586
muClosure :: TypedefName
muClosure = "@_closure"
587

588 589 590 591 592 593 594 595 596
muClosureRef :: TypedefName
muClosureRef = "@_closure_ref"
muClosureFunctionSig :: SignatureName
muClosureFunctionSig = "@_closure_function_sig"
muClosureFunction :: TypedefName
muClosureFunction = "@_closure_function"
haskellData :: TypedefName
haskellData = "@_haskell_data"

597 598 599
-- | An instruction to extract the a particular field from a closure.
getClosureField :: VarName -> ClosureField -> Expression
getClosureField n field = GetFieldIRef False muClosure (fromEnum field) n
600 601 602 603

-- | An instruction to to get the data part from a closure.
getClosureData :: VarName -> Expression
getClosureData = GetVarPartIRef False muClosure
604 605 606 607 608 609 610 611 612 613

-- | An enumeration which corresponds to the position of the fields of Mu
-- closures.
data ClosureField = EntryField
                  | TagField
                  | NArgsField
                  deriving Enum

fieldIx :: ClosureField -> C.CInt
fieldIx = fromIntegral . fromEnum
nathyong's avatar
nathyong committed
614 615 616 617 618 619


-------------------------------------------------- * Utility functions

isInternal :: NamedThing a => a -> Bool
isInternal = isInternalName . getName