Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Preliminary support for State# RealWorld.

  • Loading branch information...
commit d5c4c65bbf11e06e600a40acfab537d79fbaa313 1 parent 3af8a4c
@nominolo authored
View
14 compiler/Lambdachine/Ghc/CoreToBC.hs
@@ -65,6 +65,7 @@ import qualified TysPrim as Ghc
import qualified TyCon as Ghc
import qualified TypeRep as Ghc
import qualified Outputable as Ghc
+import qualified MkId as Ghc ( realWorldPrimId )
import TyCon ( TyCon )
import Outputable ( Outputable, showPpr, alwaysQualify, showSDocForUser )
import CoreSyn ( CoreBind, CoreBndr, CoreExpr, CoreArg, CoreAlt,
@@ -416,6 +417,10 @@ transBind x (viewGhcLam -> (bndrs, body)) env0 = do
let locs0 = mkLocs $ (x, Self) : [ (b, InReg n t) |
(b, n) <- zip bndrs [0..],
let t = Ghc.repType (Ghc.varType b) ]
+ -- The new local environment does *not* include env0, because
+ -- elements of env0 are no longer local in the body of the
+ -- lambda. They must be accessed explicitly via the free
+ -- variable environment:
env = fold2l' extendLocalEnv env0 bndrs (repeat undefined)
-- Here comes the magic:
@@ -557,6 +562,8 @@ data ValueLocation
-- ^ The value is the contents of the @Node@ pointer.
| Global Id
-- ^ The value is a top-level ID.
+ | Void
+ -- ^ The value does not have a representation.
deriving Show
-- | Maps GHC Ids to their (current) location in bytecode.
@@ -586,8 +593,10 @@ extendLocs (KnownLocs env) xls =
noLocs :: KnownLocs
noLocs = KnownLocs Ghc.emptyVarEnv
+-- The local environment always includes `realWorld#`. It doesn't
+-- actually have a runtime representation.
mkLocs :: [(Ghc.Id, ValueLocation)] -> KnownLocs
-mkLocs l = KnownLocs (Ghc.mkVarEnv l)
+mkLocs l = KnownLocs (Ghc.extendVarEnv (Ghc.mkVarEnv l) Ghc.realWorldPrimId Void)
instance Monoid KnownLocs where
mempty = noLocs
@@ -859,6 +868,9 @@ transVar x env fvi locs0 mr =
-- pointer so (Any :: *) should be fine for now.
r <- mbFreshLocal ghcAnyType mr
return (insLoadSelf r, r, True, locs0, mempty)
+ Just Void -> do
+ r <- mbFreshLocal Ghc.realWorldStatePrimTy mr
+ return (emptyGraph, r, True, locs0, mempty)
Nothing
| Just x' <- lookupLocalEnv env x -> do
-- Note: To avoid keeping track of two environments we must
View
1  compiler/Lambdachine/Ghc/Utils.hs
@@ -101,6 +101,7 @@ transType (Ghc.TyConApp tycon _)
| tycon == Ghc.bcoPrimTyCon -> AddrTy
| tycon == Ghc.addrPrimTyCon -> AddrTy
| tycon == Ghc.wordPrimTyCon -> WordTy
+ | tycon == Ghc.statePrimTyCon -> VoidTy
| otherwise ->
error $ "Unknown primitive type: " ++ showPpr tycon
| otherwise =
View
12 tests/Bc/RealWorld.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude #-}
+module Bc.RealWorld where
+
+import GHC.Prim
+import GHC.Types
+
+{-# NOINLINE f #-}
+f :: State# RealWorld -> Int
+f _s = 42
+
+test = case f realWorld# of
+ I# n -> n ==# 42#
View
26 tests/Bc/SharedFail.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude #-}
+module Bc.SharedFail where
+
+import GHC.Prim
+import GHC.Types
+import GHC.Num
+import GHC.Base
+-- import Prelude ( print )
+
+rotate :: Int -> [a] -> [a]
+rotate 2 (x1:x2:xs) = x2:x1:xs
+rotate 3 (x1:x2:x3:xs) = x2:x3:x1:xs
+rotate 4 (x1:x2:x3:x4:xs) = x2:x3:x4:x1:xs
+rotate 5 (x1:x2:x3:x4:x5:xs) = x2:x3:x4:x5:x1:xs
+rotate 6 (x1:x2:x3:x4:x5:x6:xs) = x2:x3:x4:x5:x6:x1:xs
+rotate 7 (x1:x2:x3:x4:x5:x6:x7:xs) = x2:x3:x4:x5:x6:x7:x1:xs
+rotate 8 (x1:x2:x3:x4:x5:x6:x7:x8:xs) = x2:x3:x4:x5:x6:x7:x8:x1:xs
+rotate 9 (x1:x2:x3:x4:x5:x6:x7:x8:x9:xs) = x2:x3:x4:x5:x6:x7:x8:x9:x1:xs
+rotate 10 (x1:x2:x3:x4:x5:x6:x7:x8:x9:x10:xs) = x2:x3:x4:x5:x6:x7:x8:x9:x10:x1:xs
+rotate n (x:xs) = rotate' n xs
+ where rotate' 1 xs = x:xs
+ rotate' n (x:xs) = x:rotate' (n-1) xs
+
+-- test = rotate 2 [1::Int, 2, 3] == [2, 1, 3]
+
+test = rotate 8 [1::Int, 2, 3, 4, 5, 6, 7, 8, 9] == [2,3,4,5,6,7,8,1,9]
Please sign in to comment.
Something went wrong with that request. Please try again.