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.7% of users enabled 2FA.

CodeGen.hs 27.6 KB
Newer Older
1
--
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
2
-- Copyright 2017 The Australian National University
3
--
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
4
5
6
7
8
9
10
11
12
13
14
-- Licensed under the 3-Clause BSD License (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     https://opensource.org/licenses/BSD-3-Clause
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
15
16
--

nathyong's avatar
nathyong committed
17
18
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
19
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
20
{-# LANGUAGE OverloadedStrings #-}
21

Pavel Zakopaylo's avatar
Cleanup    
Pavel Zakopaylo committed
22
23
module Compiler.Mu.CodeGen where

24

25
import Control.Applicative ((<|>))
26
import Control.Monad.IO.Class (MonadIO, liftIO)
nathyong's avatar
nathyong committed
27
import Control.Monad.Reader (Reader, ReaderT, MonadReader, runReaderT, ask, local, reader)
28
import Control.Monad.State.Strict (State, StateT, MonadState, evalState, runStateT, gets, get)
nathyong's avatar
nathyong committed
29
import Control.Monad.Trans (MonadTrans, lift)
30
import Control.Monad.Writer (Writer, WriterT, MonadWriter, runWriterT, tell)
31
import Data.Binary (Binary)
32
import Data.Foldable (toList, foldl')
33
import Data.List (genericLength)
34
import Data.Map.Strict (Map)
35
36
37
import Data.Monoid ((<>))
import Data.Sequence (Seq, (|>))
import Data.String (fromString)
38
import Data.Bits.Floating
39
import GHC.Generics (Generic)
40
import qualified Data.ByteString as B
nathyong's avatar
nathyong committed
41
import qualified Data.Sequence as S
42
import qualified Data.Map.Strict as M
43
44
import qualified Foreign as F
import qualified Foreign.C as C
45

nathyong's avatar
nathyong committed
46
import Language.Haskell.GHC.Simple (ModMetadata(..), mmSummary)
47
import           Lens.Micro.Platform ((%=), view, Lens')
48

49
import           FastString (fsLit, zEncodeFS, zString)
50
import qualified GHC
51
import           Name (NamedThing (..), nameStableString, isSystemName, isInternalName)
52
import           Unique (Uniquable (..))
53

54
55
56
import           Mu.API
import           Mu.AST
import           Mu.Interface
57
import           Mu.PrettyPrint
58

59
import Debug.Trace
60

61
-------------------------------------------------- * Data types
62

63
64
-- | Top-level constructs which need to be allocated and populated in the Mu
-- separately.
65
66
data TopLevel = InfoTableCell GlobalCellName InfoTable -- ^ Specialized info table (e.g. thunk, pap etc.)
              | Closure
67
                    GlobalCellName  -- ^ Name of the closure
68
                    TypedefName     -- ^ Type of the closure
69
                    GlobalCellName  -- ^ pointer to associated info table
70
                    [UnboxedData]   -- ^ Payload
71
              | ByteArray GlobalCellName B.ByteString -- ^ strings, mainly for DataCon descriptors
72
    deriving (Generic, Show)
73
74

instance Binary TopLevel
75

76
77
instance HasName TopLevel where
    toName tl = toName $ case tl of
78
79
        InfoTableCell n _ -> n
        Closure n _ _ _ -> n
80
81
        ByteArray n _ -> n

82
83
84
data UnboxedData = UnboxedInt Integer
                 | UnboxedDouble Rational
                 | TaggedPointer GlobalCellName Int
nathyong's avatar
nathyong committed
85
                 | NullPointer
86
    deriving (Generic, Show)
87

88
instance Binary UnboxedData
89

90

91
92
93
94
95
96
97
98
-- | All the info table entries you could ever need
--
-- With direct reference to:
--   -> https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects
--   -> https://ghc.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h
--
-- Note that the entry code is stored in the main closure itself, and not in this table
data InfoTable = SimpleInfoTable
99
                    FunctionName     -- ^ Entry code
100
101
102
103
104
105
106
107
108
109
110
111
                    ClosureType      -- ^ Type of closure
                    Int              -- ^ SRT Bitmap
               | ConsInfoTable
                    InfoTable        -- ^ Base case, should only ever be SimpleInfoTable
                    GlobalCellName   -- ^ constructor description (necessary?)
               | FunInfoTable
                    InfoTable
                    Int              -- ^ function type (necessary?)
                    Int              -- ^ function arity
               | ThunkInfoTable
                    InfoTable
                    GlobalCellName   -- ^ SRT
112
113
114
    deriving (Generic, Show)

instance Binary InfoTable
115

116

117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
-- | Static data for runtime-generated info tables
data RunTimeInfoTable = RTSimpleInfoTable
                            FunctionName     -- ^ Entry code
                            ClosureType      -- ^ Type of closure
                            VarName          -- ^ SRT Bitmap
                      | RTConsInfoTable
                            RunTimeInfoTable -- ^ Base case, should only ever be RTSimpleInfoTable
                            GlobalCellName   -- ^ constructor description (necessary?)
                      | RTFunInfoTable
                            RunTimeInfoTable
                            VarName          -- ^ function type (necessary?)
                            VarName          -- ^ function arity
                      | RTThunkInfoTable
                            RunTimeInfoTable
                            GlobalCellName   -- ^ SRT
    deriving (Generic, Show)

instance Binary RunTimeInfoTable


137
138
139
140
-- | The type of a closure - these will be converted to numerical
--   values and written directly to the Mu datastructure
--
-- Not sure if they are all necessary..
141
142
143
144
145
146
147
148
149
150
151
data ClosureType = Constructor
                 | StaticConstructor
                 | Function
                 | StaticFunction
                 | Thunk
                 | StaticThunk
                 | SelectorThunk
                 | PartialApplication
                 | GenericApplication
                 | StackApplication
                 | Indirection
152
                 | StaticIndirection
153
                 | BlackHole
154
                 | RET
155
156
157
158
159
160
161
162
                 deriving (Enum, Generic, Show)
                 
instance Binary ClosureType

typeIx :: ClosureType -> C.CLong
typeIx = fromIntegral . fromEnum


163
-- | An enumeration which corresponds to the position of the fields in info tables
164
-- See: https://ghc.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h
165
166
167
168
169
170
171
data InfoTableField = EntryField
                    | TypeField
                    | SRTBitmapField   -- Or constructor tag
                  deriving (Enum, Generic, Show)

instance Binary InfoTableField

172
infoIx :: Integral i => InfoTableField -> i
173
174
infoIx = fromIntegral . fromEnum

175

176
177
178
179
180
181
182
183
-- | An extension of the info table fields for closures that need them
data SpecInfoTableField = ConsDescField
                        | FunTypeField
                        | FunArityField
                        | SRTField
                      deriving (Generic, Show)
                      
instance Binary SpecInfoTableField
184

185

186
187
188
189
190
191
-- | Identification of fields in a TSO objects
-- See: https://ghc.haskell.org/trac/ghc/browser/includes/rts/storage/TSO.h

-- XXX: We'll be adding more fields later; this is just so that we can
-- have a stack pointer. Note that any additions will need to be
-- duplicated in the 'muTSO' typedef
192
data TSOFields = TSOHeader -- XXX: Why is this required?
193
194
195
196
197
198
199
200
               | TSOLink
               | TSOGlobalLink
               | TSOSp
               | TSOWhatNext
               | TSOWhyBlocked
               | TSOFlags
               | TSOBlockInfo
               | TSOId
201
             deriving (Enum)
202
203


204
-- | The position of any field within an info table
205
206
207
--
-- Obviously, two fields with the same number here cannot
-- exist in the same closure
208
infoIx' :: Integral i => SpecInfoTableField -> i
209
infoIx' fld = case fld of
210
211
212
213
    ConsDescField   -> 1
    FunTypeField    -> 1
    FunArityField   -> 2
    SRTField        -> 1
214
215


216
-- | The position of any field within the basic closure
217
-- (or stack frame!)
218
data ClosureField = ClosInfoTable
219
                  | ClosLink
220
221
222
                 deriving (Enum, Generic, Show)
                 
instance Binary ClosureField
223

224
225
226
fieldIx :: ClosureField -> C.CInt
fieldIx = fromIntegral . fromEnum

227

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
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
243
244
245
246
247
248

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

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

249
-- | Run a Mu computation from the empty state, storing the result.
nathyong's avatar
nathyong committed
250
251
runMu :: MuState -> Mu a -> a
runMu state (Mu code) = evalState code state
252
253

data MuState = MuState
254
    { _uniqueID :: !Int
nathyong's avatar
nathyong committed
255
    , _moduleName :: String
256
257
    , _definitions :: Seq Definition
    , _topLevels :: Seq TopLevel
258
    , _topBinds :: M.Map GHC.Id GlobalCellName
259
    , _mainFunc :: Maybe (VarName, VarName, TypedefName)
260
261
    }

nathyong's avatar
nathyong committed
262
263
264
265
266
267
268
269
270
271
272
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))
273

274
275
276
topBinds :: Lens' MuState (M.Map GHC.Id GlobalCellName)
topBinds k m = fmap (\new -> m { _topBinds = new }) (k (_topBinds m))

277
mainFunc :: Lens' MuState (Maybe (VarName, VarName, TypedefName))
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
278
279
mainFunc k m = fmap (\new -> m { _mainFunc = new }) (k (_mainFunc m))

280
281
-------------------------------------------------- * Block building monad

nathyong's avatar
nathyong committed
282
-- | Read only state for building blocks.
283
type CapturedIDs = Map GHC.Id (VarName, TypedefName)
nathyong's avatar
nathyong committed
284
285
286
287
288
289

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

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

nathyong's avatar
nathyong committed
291
292
-- | An environment for outputing individual instructions.
type ExpWriter = WriterT [Assigned Expression] Blocks
293
294


nathyong's avatar
nathyong committed
295
296
297
298
299
-- | 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)
300
301


nathyong's avatar
nathyong committed
302
303
304
305
306
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
307

308

nathyong's avatar
nathyong committed
309
310
311
312
-- | Run a 'Blocks' computation inside a local environment capturing extra
-- variables.
capturing :: MonadReader CapturedIDs m
          => m a  -- ^ Computation to run
313
          -> Map GHC.Id (VarName, TypedefName)  -- ^ Extra variables to capture
nathyong's avatar
nathyong committed
314
315
316
317
318
          -> m a
capturing b r = local (M.union r) b


sortedIDNames :: MonadReader CapturedIDs m => m [VarName]
319
sortedIDNames = ask >>= return . fmap (fst . snd) . M.toAscList
nathyong's avatar
nathyong committed
320
321


322
323
-- | Obtain the name and type for a particular 'GHC.Id' in the current mapping.
-- If it does not exist, crash and burn spectacularly.
324
lookupID :: GHC.Id -> ExpWriter (VarName, TypedefName)
nathyong's avatar
nathyong committed
325
326
327
lookupID i = lift $ do
    n <- reader (M.lookup i)
    case n of
328
329
330
331
332
        Nothing -> liftBlocks $ do
            state <- get
            case M.lookup i $ _topBinds state of
                Nothing -> error ("lookupID: could not find " ++ stringify i)
                Just n' -> case n' of
333
                    GlobalCellName n'' -> return (VarName n'', muClosureIref)
nathyong's avatar
nathyong committed
334
335
336
337
        Just n' -> return n'


-- | Lift a 'Mu' computation into the 'Blocks' monad.
338
liftBlocks :: Mu a -> Blocks a
339
340
341
342
343
344
liftBlocks = Blocks . lift . lift


-- | Lift a 'Mu' computation into the 'ExpWriter' monad
liftExpr :: Mu a -> ExpWriter a
liftExpr = lift . liftBlocks
345
346
347
348


-- | Emit a basic block without an exceptional parameter.
basicBlock
349
    :: BasicBlockName            -- ^ Name of the block itself
nathyong's avatar
nathyong committed
350
    -> [(VarName, TypedefName)]  -- ^ Parameters of the block, and their types
351
    -> ExpWriter Expression      -- ^ Code to generate expressions within the block
352
353
    -> Blocks BasicBlock
basicBlock n params exprs = do
nathyong's avatar
nathyong committed
354
355
    bindings <- ask
    (terminator, body) <- runWriterT exprs `capturing` newMappings n bindings
356
    return $ BasicBlock n (params ++ paramsFor n bindings) Nothing body terminator
nathyong's avatar
nathyong committed
357
358
359
360


-- | Generate a new mapping for 
newMappings :: BasicBlockName
361
            -> Map GHC.Id (VarName, TypedefName)
nathyong's avatar
nathyong committed
362
363
364
            -> CapturedIDs
newMappings block mapping = M.mapWithKey genParam mapping
  where
365
366
    genParam i (_, varType) = (block `dot` tail (stringify i), varType)

nathyong's avatar
nathyong committed
367
368
369

-- | Obtain a list of variables and their types
paramsFor :: BasicBlockName
370
          -> Map GHC.Id (VarName, TypedefName)
nathyong's avatar
nathyong committed
371
372
          -> [(VarName, TypedefName)]
paramsFor block mapping = fmap pairUp (M.toAscList mapping)
373
  where
374
375
    pairUp (id, (_, varType)) = (block `dot` tail (stringify id), varType)

376
377

-- | Assign the result of a Mu 'Expression' to a 'VarName'.
378
379
assign :: BasicBlockName -> Expression -> ExpWriter VarName
assign block expr = do
380
    uid <- liftExpr nextMuUnique
381
    let n = fromString (block `dot` "var" ++ uid)
nathyong's avatar
nathyong committed
382
    emit' $ [n] := expr
383
384
385
    return n


386
-- | Run a Mu 'Expression' without binding to anything.
nathyong's avatar
nathyong committed
387
388
389
390
391
392
393
394
395
396
emit :: Expression -> ExpWriter ()
emit expr = emit' $ [] := expr


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


emitBB :: BasicBlock -> Blocks ()
emitBB = tell . pure
397

398

399
400
-- | Declare a (constant) tag to be defined at the top level, without
-- clobbering any other upvalues.
nathyong's avatar
nathyong committed
401
upTag :: Int -> ExpWriter VarName
402
upTag i = liftExpr $ do
403
404
405
    let n = fromString ("@tag_const_" ++ show i)
    constant n muClosureTag (IntCtor (fromIntegral i))
    return (VarName $ toName n)
406

407

nathyong's avatar
nathyong committed
408
409
410
-- | Declare an integer constant to be defined at the top level, without
-- clobbering any other upvalues.
upConstant :: Int -> ExpWriter VarName
411
upConstant i = liftExpr $ do
nathyong's avatar
nathyong committed
412
413
414
415
416
    let n = fromString ("@i64_" ++ show i)
    constant n i64 (IntCtor (fromIntegral i))
    return (VarName $ toName n)


417
-- | Declare a (constant) value to be defined at the top level.
nathyong's avatar
nathyong committed
418
upValue :: ConstConstructor -> TypedefName -> ExpWriter VarName
419
upValue ctor ty = liftExpr $ do
420
    uid <- nextMuUnique
nathyong's avatar
nathyong committed
421
    let n = fromString ("@upvar" ++ uid)
422
    constant n ty ctor
423
    return (VarName $ toName n)
424
425


426
427
-------------------------------------------------- * Code generation

428
-- | Extract the definitions and other useful things from the Mu monad.
nathyong's avatar
nathyong committed
429
430
bundleMu :: String -> Mu () -> MuResult
bundleMu modName codegen = runMu initialState $ do
431
    -- XXX: Order is important
432
    codegen
433
    mainFunc <- haskellMain =<< gets _mainFunc
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
434
435
436
437
438
    defns    <- gets _definitions
    tops     <- gets _topLevels
    
    return (defns, tops, mainFunc)

nathyong's avatar
nathyong committed
439
  where
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
440
441
442
443
444
445

    initialState = MuState 0 modName mempty mempty mempty Nothing


-- | Generates main function that evaluates selected closure
-- NOTE: Will fail (VM panic) if called (with Just) multiple times
446
haskellMain :: Maybe (VarName, VarName, TypedefName) -> Mu (Maybe FunctionName)
447
haskellMain m = case m of
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
448
449
    Nothing -> return Nothing
    
450
    Just (entry, closure, closMuRefType) -> do    
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
451
452
453
454
455
456
457
458
        typedef "@pi8"  $ UPtr i8
        typedef "@ppi8" $ UPtr "@pi8"
        funcsig "@_haskell_main_sig" [i64, "@ppi8"] []
        
        funcdef "@_haskell_main" (Version "1") "@_haskell_main_sig" $
            basicBlock "@_haskell_main.entry"
                [("@_haskell_main.entry.argc", i64),
                 ("@_haskell_main.entry.argv", "@ppi8")] $ do
459
460
461
462
463
464
                     emit' $ ["@_haskell_main.entry.target"] :=
                        ConvertOperation REFCAST closMuRefType
                            muClosureIref closure
                     
                     return $ TailCall muClosureFunctionSig entry
                        ["@_haskell_main.entry.target"]
Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
465
466
        
        return $ Just "@_haskell_main"
467
468
469


-------------------------------------------------- * Mu interface
470

nathyong's avatar
nathyong committed
471
472
-- | Get a unique identifier (name) from the Mu monad.
nextMuUnique :: Mu String
473
474
nextMuUnique = do
    currentID <- gets _uniqueID
nathyong's avatar
nathyong committed
475
    modName <- gets _moduleName
476
    uniqueID %= (+1)
nathyong's avatar
nathyong committed
477
    return $ "_uq_" <> modName <> "_" <> show currentID
478

479
480
481
482
483

-- | Emit an info table, to be allocated at build time
emitInfo :: GlobalCellName -> InfoTable -> Mu ()
emitInfo name table = do
    topLevels %= (|> InfoTableCell name table)
484
485
486
487
488
489
490
    definitions %= (|> GlobalCell name tableType)
  where
    tableType = case table of
        SimpleInfoTable {} -> infoTable
        ConsInfoTable   {} -> consInfoTable
        FunInfoTable    {} -> funInfoTable
        ThunkInfoTable  {} -> thunkInfoTable
491
492


493
494
-- | Emit a closure with a payload and an entry function.  The closure itself
-- will be allocated during build time.
495
closure :: (Uniquable a, NamedThing a)
496
497
        => a -> GlobalCellName -> [UnboxedData] -> Mu ()
closure name table payload = do
498
499
500
501
    let unboxedType :: UnboxedData -> TypedefName
        unboxedType un = case un of
            UnboxedInt    _   -> i64
            UnboxedDouble _   -> double
502
503
            TaggedPointer _ _ -> muClosureIref
            NullPointer       -> muClosureIref
504
    
505
    topLevels %= (|> Closure name' closMuType table payload)
506
    definitions %= (|> GlobalCell name' closMuType)
507
508
509
510
    
    -- We define a new Mu type for each closure, since each may have
    -- a different payload.
    definitions %= (|> TypeDefinition closMuType (Struct $
511
        muClosure : map unboxedType payload))
512
513
514
    
    definitions %= (|> TypeDefinition closMuRefType (IRef closMuType))

515
  where
516

517
    name' = closureNameOf name
518
    closMuType = closureTypeNameOf name
519
    closMuRefType = closureRefTypeNameOf name
520
521


522
-- | Emit a string.  The string itself will be allocated during build time.
523
524
string :: (Uniquable a, NamedThing a) =>
    a -> B.ByteString -> Mu GlobalCellName
525
526
string name bytes = do
    name' <- do
527
        uid <- nextMuUnique
nathyong's avatar
nathyong committed
528
        return $ fromString $ stringify name <> uid <> "_str"
529
    definitions %= (|> GlobalCell name' muStringRef)
530
531
532
533
534
    topLevels %= (|> ByteArray name' bytes)
    return name'


-- | Emit a type definition.
535
536
537
538
typedef :: TypedefName -> Type -> Mu ()
typedef n ty = definitions %= (|> TypeDefinition n ty)


539
-- | Emit a constant definition.
540
541
542
543
constant :: ConstantName -> TypedefName -> ConstConstructor -> Mu ()
constant n ty ctor = definitions %= (|> Constant n ty ctor)


544
-- | Emit a function signature definition.
545
546
funcsig :: SignatureName -> [TypedefName] -> [TypedefName] -> Mu ()
funcsig n argtys rettys = definitions %= (|> SignatureDefinition n argtys rettys)
547

nathyong's avatar
nathyong committed
548

549
-- | Emit a function (version) definition.
550
551
funcdef :: FunctionName -> Version -> SignatureName -> Blocks BasicBlock -> Mu ()
funcdef n v sig body = do
nathyong's avatar
nathyong committed
552
    (entry, bblocks) <- runBlocks M.empty body
Pavel Zakopaylo's avatar
Cleanup    
Pavel Zakopaylo committed
553
554
    traceM $ pp entry
    mapM_ (traceM . pp) bblocks
555
    definitions %= (|> FunctionDefinition n v sig entry (toList bblocks))
nathyong's avatar
nathyong committed
556

557

558
559
primfuncdef :: FunctionName -> Blocks BasicBlock -> Mu ()
primfuncdef n body = funcdef n (Version "1") muClosureFunctionSig body
560

561
562
563
constToVar :: ConstantName -> VarName
constToVar (ConstantName n) = VarName n

564
565
566
567
568

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

stringify :: (Uniquable a, NamedThing a) => a -> String
stringify a
nathyong's avatar
nathyong committed
569
570
    | isSystemName name || isInternalName name =
        '@':(stableName name <> "_" <> uniquePart a)
571
    | otherwise = '@':(stableName name)
572
  where
573
574
    name = getName a
    stableName = zString . zEncodeFS . fsLit . nameStableString
575
576
    uniquePart = show . getUnique

577

578
closureNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
579
closureNameOf n = GlobalCellName $ Name $ stringify n <> "_closure"
580

Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
581
582
583
closureNameOf' :: (Uniquable a, NamedThing a) => a -> VarName
closureNameOf' n = VarName $ Name $ stringify n <> "_closure"

584
585
586
closureTypeNameOf :: (Uniquable a, NamedThing a) => a -> TypedefName
closureTypeNameOf n = TypedefName $ Name $ stringify n <> "_clostype"

587
588
589
closureRefTypeNameOf :: (Uniquable a, NamedThing a) => a -> TypedefName
closureRefTypeNameOf n = TypedefName $ Name $ stringify n <> "_refclostype"

590
entryNameOf :: GHC.Id -> FunctionName
591
entryNameOf n = FunctionName $ Name $ stringify n <> "_entry"
592

Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
593
594
595
entryNameOf' :: GHC.Id -> VarName
entryNameOf' n = VarName $ Name $ stringify n <> "_entry"

596
597
598
599
600
signatureNameOf :: FunctionName -> SignatureName
signatureNameOf n = case n of
    FunctionName (Name n) -> SignatureName $ Name (n <> "_sig")


Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
601
dataConEntry :: (Uniquable a, NamedThing a) => a -> FunctionName
602
603
dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry"

604
605
606
dataConEntry' :: (Uniquable a, NamedThing a) => a -> VarName
dataConEntry' n = VarName $ Name $ stringify n <> "_static_entry"

607
608
609
infoNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
infoNameOf n = GlobalCellName $ Name $ stringify n <> "_con_info"

Pavel Zakopaylo's avatar
Pavel Zakopaylo committed
610
611
conInfoNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
conInfoNameOf n = GlobalCellName $ Name $ stringify n <> "_clos_info"
612

613
614
615
616
617
618
staticInfoNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
staticInfoNameOf n = GlobalCellName $ Name $ stringify n <> "_static_info"

wrapperNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
wrapperNameOf n = GlobalCellName $ Name $ stringify n <> "_info"

619
620
621
622
623
624
625

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

-- | Load a bunch of useful types into the current bundle.  The order of the
-- definitions is arbitrary.
loadTypes :: Mu ()
loadTypes = do
626
    typedef void Void
627
    typedef iref_void $ IRef void
628
    typedef  ref_void $  Ref void
629
    funcsig muClosureFunctionSig [muClosureIref] [] -- default function signature
630
                                                    -- (although this would be a thunk's exact signature)
631
632
633

    typedef muClosureTag $ MuInt 3 -- low bit tag, 3 bits for 64-bit aligned closures

634
    typedef i64 $ MuInt 64
635
    typedef i32 $ MuInt 32
636
637
638
639
640
    constant stdin  i32 $ IntCtor 0
    constant stdout i32 $ IntCtor 1
    constant stderr i32 $ IntCtor 2
    constant i64_0 i64 $ IntCtor 0
    constant i64_1 i64 $ IntCtor 1
641
642
    typedef float MuFloat
    typedef double MuDouble
643
    typedef i8 $ MuInt 8
644
    typedef i16 $ MuInt 16
645
    typedef muString $ Hybrid [] i8
646
    typedef muStringRef $ Ref muString
647
    typedef muStringPtr $ UPtr muString
648
    typedef muClosureFunction $ FuncRef muClosureFunctionSig
649
    
650
651
    -- | The STG "closure" - this represents objects in the heap (H). With reference to:
    -- "Making a Fast Curry: Push/Enter vs. Eval/Apply for Higher-order Languages"
652
    --
653
654
655
656
657
658
659
660
661
662
    -- Importantly, payloads are implemented by creating a struct with a 'muClosure'
    -- as its first field, and using prefix-rule to refer to such closures via the
    -- 'muClosure' type.
    --
    -- Declaring 'muClosure' as a struct instead of just making it an alias for
    -- 'infoTableRef' itself is currently somewhat pointless. However, I am taking
    -- the queue from GHC's implementation, which has an explicit "header" struct
    -- despite usually only containing the info table pointer. In GHC's case this
    -- is done so that a pointer to the profiling info can be added is necessary,
    -- which is a feature we may want to support.
663
664
    typedef muClosure $ Struct [infoTableIref]
    typedef muClosureIref $ IRef muClosure
665
    
666
667
668
669
670
    -- | The stack shall be linked list in the heap, so our header
    -- has an info table reference and a link to the previous frame.
    --
    -- As usual, this is the "basic" stack frame; more fields are added
    -- via prefix rule
671
672
    typedef muStackFrame $ Struct [retInfoTableIref, muStackFrameRef]
    typedef muStackFrameRef $ Ref muStackFrame
673
    
674
675
    constant nullStackFrameRef muStackFrameRef NullCtor
    
676
677
    -- | A closure's info table (basic version)
    -- See 'InfoTableField' enumeration
678
    typedef infoTable $ Struct [muClosureFunction, i32, i32]
679
    typedef infoTableIref $ IRef infoTable
680
681
682
683
684
685
686
687
688
    
    -- | Specialized info tables
    --
    -- These are (all) given by the 'InfoTable' enumeration
    -- The identity of each field can be obtained from the
    -- 'SpecInfoTableField' enumeration.
    --
    -- Note also that these can all be referred to as ref<infoTable>
    -- via Mu's prefix rule.
689
    typedef consInfoTable $ Struct [infoTable, muStringRef]
690
    typedef funInfoTable $ Struct [infoTable, i32, i32]
691
    typedef thunkInfoTable $ Struct [infoTable, muStringRef]
692
693
694
695
    
    typedef consInfoTableIref $ IRef consInfoTable
    typedef funInfoTableIref $ IRef funInfoTable
    typedef thunkInfoTableIref $ IRef thunkInfoTable
696
    
697
698
699
700
    -- | The Thread State Object (TSO)
    -- Mainly implemented to we have a sensible place to put the Sp
    -- See: https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects#ThreadStateObjects
    -- See the 'TSOFields' enum for what these fields actually are
701
702
703
    typedef muTSO $ Struct [muClosure, muTSORef, muTSORef, muStackFrameRef,
                            i16, i16, i32, ptr_void, i32]
    
704
705
706
    typedef muTSORef $ Ref muTSO
    
    typedef ptr_void $ UPtr void
707
708
709
710


void :: TypedefName
void = "@void"
711
712
ptr_void :: TypedefName
ptr_void = "@ptr_void"
713
714
iref_void :: TypedefName
iref_void = "@iref_void"
715
716
ref_void :: TypedefName
ref_void = "@ref_void"
717
718
i32 :: TypedefName
i32 = "@i32"
719
720
721
722
723
724
stdin  :: ConstantName
stdin  = "@_fd_stdin"
stdout :: ConstantName
stdout = "@_fd_stdout"
stderr :: ConstantName
stderr = "@_fd_stderr"
725
726
i64 :: TypedefName
i64 = "@i64"
727
728
i64_0 :: ConstantName
i64_0 = "@i64_0"
729
730
i64_1 :: ConstantName
i64_1 = "@i64_1"
731
732
733
734
float :: TypedefName
float = "@float"
double :: TypedefName
double = "@double"
735
736
i8 :: TypedefName
i8 = "@i8"
737
738
i16 :: TypedefName
i16 = "@i16"
739
740
muString :: TypedefName
muString = "@string_t"
741
742
743
744
muStringRef :: TypedefName
muStringRef = "@string_t_iref"
muStringPtr :: TypedefName
muStringPtr = "@string_t_ptr"
745

746
747
748
749
consDesc :: TypedefName
consDesc = "@_closure_cons_desc"
srt :: TypedefName
srt = "@_closure_srt"
750

751
-------------------------------------------------- * STG Closures in Mu
752

753
-- | The Mu closure itself.
754
755
muClosure :: TypedefName
muClosure = "@_closure"
756

757
758
759
muStackFrame :: TypedefName
muStackFrame = "@_stack_frame"

760
761
762
muStackFrameRef :: TypedefName
muStackFrameRef = "@_stack_frame_ref"

763
764
765
nullStackFrameRef :: ConstantName
nullStackFrameRef = "@stack_frame_ref_null"

766
767
768
769
muTSO :: TypedefName
muTSO = "@_tso"
muTSORef :: TypedefName
muTSORef = "@_tso_ref"
770

771
772
773
muClosureTag :: TypedefName
muClosureTag = "@_tag"

774
775
infoTable :: TypedefName
infoTable = "@_closure_info_table"
776
777
infoTableIref :: TypedefName
infoTableIref = "@_closure_info_table_iref"
778
779
780
781
782
783

consInfoTable :: TypedefName
consInfoTable = "@_closure_cons_info_table"
funInfoTable :: TypedefName
funInfoTable = "@_closure_fun_info_table"
thunkInfoTable :: TypedefName
784
thunkInfoTable = "@_closure_thunk_or_ret_info_table"
785

786
787
788
789
790
consInfoTableIref :: TypedefName
consInfoTableIref = "@_closure_cons_info_table_iref"
funInfoTableIref :: TypedefName
funInfoTableIref = "@_closure_fun_info_table_iref"
thunkInfoTableIref :: TypedefName
791
792
793
thunkInfoTableIref = "@_closure_thunk_or_ret_info_table_iref"
retInfoTableIref :: TypedefName
retInfoTableIref = thunkInfoTableIref
794

795
796
797
nullSRT :: GlobalCellName
nullSRT = "@_closure_null_srt"

798
799
muClosureIref :: TypedefName
muClosureIref = "@_closure_iref"
800
801
802
803
804
muClosureFunctionSig :: SignatureName
muClosureFunctionSig = "@_closure_function_sig"
muClosureFunction :: TypedefName
muClosureFunction = "@_closure_function"

805
806
807
808
809
810
811
writeSig :: SignatureName
writeSig = "@_extern_write_sig"
writePtr :: ConstantName
writePtr = "@_extern_write_ptr"
writePtrType :: TypedefName
writePtrType = "@_extern_write_ptr_type"

812
813
814
815
816
817
818
819
allThreads :: GlobalCellName
allThreads = "@_scheduler_all_threads"

initStackFrameInfoTable :: GlobalCellName
initStackFrameInfoTable = "@init_stack_frame_info_table"
initStackFrameFun :: FunctionName
initStackFrameFun = "@init_stack_frame_fun"

nathyong's avatar
nathyong committed
820
821
822
823
824

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

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