cabal-testsuite/PackageTests/CmmSources/src/Demo.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 {-# LANGUAGE GHCForeignImportPrim #-}
   4 {-# LANGUAGE MagicHash #-}
   5 {-# LANGUAGE UnliftedFFITypes #-}
   6 module Demo (main) where
   7
   8 #include "MachDeps.h"
   9
  10 import Data.Bits
  11 import GHC.Exts
  12 import Numeric (showHex)
  13
  14 foreign import prim "aToMyWordzh" aToWord# :: Any -> Word#
  15
  16 tAG_MASK :: Int
  17 tAG_MASK = (1 `shift` TAG_BITS) - 1
  18
  19 data Box = Box Any
  20
  21 instance Show Box where
  22    showsPrec _ (Box a) rs =
  23     -- unsafePerformIO (print "↓" >> pClosure a) `seq`
  24     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
  25      where
  26        ptr  = W# (aToWord# a)
  27        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
  28        addr = ptr - tag
  29        pad_out ls = '0':'x':ls
  30
  31 asBox :: a -> Box
  32 asBox x = Box (unsafeCoerce# x)
  33
  34 main :: IO ()
  35 main = do
  36     let box = asBox "foobar"
  37     putStrLn $ "In Box we have " ++ show box