├── stack.yaml ├── my_lib.c ├── manual-stg-experiment.cabal ├── README.md ├── StgLoopback.hs └── StgSample.hs /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.22 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /my_lib.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void print_float(float v) { 4 | printf("my float value: %f\n", v); 5 | } 6 | 7 | void print_double(double v) { 8 | printf("my double value: %lf\n", v); 9 | } 10 | -------------------------------------------------------------------------------- /manual-stg-experiment.cabal: -------------------------------------------------------------------------------- 1 | name: manual-stg-experiment 2 | version: 0.1.0.0 3 | license: BSD3 4 | author: Csaba Hruska 5 | maintainer: csaba.hruska@gmail.com 6 | copyright: 2020 Csaba Hruska 7 | category: Compiler 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | library 12 | hs-source-dirs: . 13 | exposed-modules: 14 | StgLoopback 15 | StgSample 16 | 17 | build-depends: 18 | base 19 | , mtl 20 | , bytestring 21 | , ghc 22 | , ghc-paths 23 | 24 | default-language: Haskell2010 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # manual-stg-experiment 2 | 3 | Manually constructed STG programs compiled with the standard GHC codegen backend. 4 | 5 | The samples show various use cases i.e. (de)construction of (un)boxed tuples and (un)lifted ADTs and using FFI. 6 | 7 | This experiment suggests that GHC codegen and RTS can be used as generic compiler backend for strict and lazy functional languages. 8 | 9 | ### Build 10 | 11 | ``` 12 | stack setup 13 | stack build 14 | ``` 15 | 16 | ### Usage 17 | 18 | ``` 19 | stack ghci StgSample.hs 20 | ``` 21 | 22 | Run a sample in GHCi. i.e. 23 | 24 | ``` 25 | *StgSample> sampleADT2 26 | ``` 27 | 28 | It will generate an executable named `a.out` also will generate the intermediate output files (`out.ll`, `out.s`, `out.o`). 29 | -------------------------------------------------------------------------------- /StgLoopback.hs: -------------------------------------------------------------------------------- 1 | module StgLoopback where 2 | 3 | -- Compiler 4 | import GHC 5 | import DynFlags 6 | import ErrUtils 7 | import Platform ( platformOS, osSubsectionsViaSymbols ) 8 | import HscTypes 9 | import Outputable 10 | import GHC.Paths ( libdir ) 11 | import DriverPipeline 12 | import DriverPhases 13 | 14 | -- Stg Types 15 | import Module 16 | import Stream (Stream) 17 | import qualified Stream 18 | import StgSyn 19 | import CostCentre 20 | import CodeOutput 21 | import StgLint 22 | 23 | -- Core Passes 24 | import StgCmm (codeGen) 25 | import Cmm 26 | import CmmInfo (cmmToRawCmm ) 27 | import CmmPipeline (cmmPipeline) 28 | import CmmBuildInfoTables (emptySRT) 29 | import UniqSupply ( mkSplitUniqSupply, initUs_ ) 30 | 31 | import Control.Monad.Trans 32 | import Control.Monad 33 | 34 | ------------------------------------------------------------------------------- 35 | -- Module 36 | ------------------------------------------------------------------------------- 37 | 38 | modl :: Module 39 | modl = mkModule mainUnitId (mkModuleName ":Main") 40 | 41 | modloc :: ModLocation 42 | modloc = ModLocation 43 | { ml_hs_file = Nothing 44 | , ml_hi_file = "Example.hi" 45 | , ml_obj_file = "Example.o" 46 | } 47 | 48 | ------------------------------------------------------------------------------- 49 | -- Compilation 50 | ------------------------------------------------------------------------------- 51 | 52 | data Backend = NCG | LLVM 53 | 54 | compileProgram :: Backend -> [TyCon] -> [StgTopBinding] -> IO () 55 | compileProgram backend tyCons topBinds = runGhc (Just libdir) $ do 56 | dflags <- getSessionDynFlags 57 | 58 | liftIO $ do 59 | putStrLn "==== STG ====" 60 | putStrLn $ showSDoc dflags $ pprStgTopBindings topBinds 61 | putStrLn "==== Lint STG ====" 62 | lintStgTopBindings dflags True "Manual" topBinds 63 | 64 | -- construct STG program manually 65 | -- TODO: specify the following properly 66 | {- 67 | type CollectedCCs 68 | = ( [CostCentre] -- local cost-centres that need to be decl'd 69 | , [CostCentreStack] -- pre-defined "singleton" cost centre stacks 70 | ) 71 | -} 72 | let ccs = emptyCollectedCCs :: CollectedCCs 73 | hpc = emptyHpcInfo False 74 | 75 | -- backend 76 | let 77 | outFname = "out.ll" 78 | 79 | (target, link) = case backend of 80 | LLVM -> (HscLlvm, LlvmOpt) 81 | NCG -> (HscAsm, As False) 82 | 83 | -- Compile & Link 84 | dflags <- getSessionDynFlags 85 | setSessionDynFlags $ 86 | dflags { hscTarget = target, ghcLink = LinkBinary } 87 | `gopt_set` Opt_KeepSFiles 88 | `gopt_set` Opt_KeepLlvmFiles 89 | -- `dopt_set` Opt_D_dump_cmm 90 | `dopt_set` Opt_D_dump_cmm_raw 91 | -- `dopt_set` Opt_D_dump_cmm_from_stg 92 | `dopt_set` Opt_D_dump_timings 93 | `gopt_set` Opt_DoStgLinting 94 | `gopt_set` Opt_DoCmmLinting 95 | 96 | dflags <- getSessionDynFlags 97 | 98 | env <- getSession 99 | liftIO $ do 100 | newGen dflags env outFname modl tyCons ccs topBinds hpc 101 | oneShot env StopLn [(outFname, Just link), ("my_lib.c", Nothing)] 102 | pure () 103 | {- 104 | TODO: 105 | prevent linking haskell libraries i.e. base, integer-gmp, ghc-prim 106 | -} 107 | 108 | ------------- 109 | -- from GHC 110 | ------------- 111 | 112 | newGen :: DynFlags 113 | -> HscEnv 114 | -> FilePath 115 | -> Module 116 | -> [TyCon] 117 | -> CollectedCCs 118 | -> [StgTopBinding] 119 | -> HpcInfo 120 | -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)]) 121 | newGen dflags hsc_env output_filename this_mod data_tycons cost_centre_info stg_binds hpc_info = do 122 | -- TODO: add these to parameters 123 | let location = modloc 124 | foreign_stubs = NoStubs 125 | foreign_files = [] 126 | dependencies = [] 127 | 128 | cmms <- {-# SCC "StgCmm" #-} 129 | doCodeGen hsc_env this_mod data_tycons 130 | cost_centre_info 131 | stg_binds hpc_info 132 | 133 | ------------------ Code output ----------------------- 134 | rawcmms0 <- {-# SCC "cmmToRawCmm" #-} 135 | cmmToRawCmm dflags cmms 136 | 137 | let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" 138 | (ppr a) 139 | return a 140 | rawcmms1 = Stream.mapM dump rawcmms0 141 | 142 | (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps) 143 | <- {-# SCC "codeOutput" #-} 144 | codeOutput dflags this_mod output_filename location 145 | foreign_stubs foreign_files dependencies rawcmms1 146 | return (output_filename, stub_c_exists, foreign_fps) 147 | 148 | 149 | doCodeGen :: HscEnv -> Module -> [TyCon] 150 | -> CollectedCCs 151 | -> [StgTopBinding] 152 | -> HpcInfo 153 | -> IO (Stream IO CmmGroup ()) 154 | -- Note we produce a 'Stream' of CmmGroups, so that the 155 | -- backend can be run incrementally. Otherwise it generates all 156 | -- the C-- up front, which has a significant space cost. 157 | doCodeGen hsc_env this_mod data_tycons 158 | cost_centre_info stg_binds hpc_info = do 159 | let dflags = hsc_dflags hsc_env 160 | 161 | let cmm_stream :: Stream IO CmmGroup () 162 | cmm_stream = {-# SCC "StgCmm" #-} 163 | StgCmm.codeGen dflags this_mod data_tycons 164 | cost_centre_info stg_binds hpc_info 165 | 166 | -- codegen consumes a stream of CmmGroup, and produces a new 167 | -- stream of CmmGroup (not necessarily synchronised: one 168 | -- CmmGroup on input may produce many CmmGroups on output due 169 | -- to proc-point splitting). 170 | 171 | let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg 172 | "Cmm produced by codegen" (ppr a) 173 | return a 174 | 175 | ppr_stream1 = Stream.mapM dump1 cmm_stream 176 | 177 | -- We are building a single SRT for the entire module, so 178 | -- we must thread it through all the procedures as we cps-convert them. 179 | us <- mkSplitUniqSupply 'S' 180 | 181 | -- When splitting, we generate one SRT per split chunk, otherwise 182 | -- we generate one SRT for the whole module. 183 | let 184 | pipeline_stream 185 | | gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags || 186 | osSubsectionsViaSymbols (platformOS (targetPlatform dflags)) 187 | = {-# SCC "cmmPipeline" #-} 188 | let run_pipeline us cmmgroup = do 189 | (_topSRT, cmmgroup) <- 190 | cmmPipeline hsc_env (emptySRT this_mod) cmmgroup 191 | return (us, cmmgroup) 192 | 193 | in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 194 | return () 195 | 196 | | otherwise 197 | = {-# SCC "cmmPipeline" #-} 198 | let run_pipeline = cmmPipeline hsc_env 199 | in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 200 | 201 | let 202 | dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm 203 | "Output Cmm" (ppr a) 204 | return a 205 | 206 | ppr_stream2 = Stream.mapM dump2 pipeline_stream 207 | 208 | return ppr_stream2 209 | -------------------------------------------------------------------------------- /StgSample.hs: -------------------------------------------------------------------------------- 1 | module StgSample where 2 | 3 | import StgLoopback 4 | 5 | -- Compiler 6 | import GHC 7 | import DynFlags 8 | import Outputable 9 | 10 | -- Stg Types 11 | import Name 12 | import Id 13 | import Unique 14 | import OccName 15 | import StgSyn 16 | import CostCentre 17 | import ForeignCall 18 | import FastString 19 | import BasicTypes 20 | import CoreSyn (AltCon(..)) 21 | 22 | import PrimOp 23 | import TysWiredIn 24 | import Literal 25 | import MkId 26 | import Type 27 | import TyCon 28 | import TysPrim 29 | import DataCon 30 | 31 | import UnariseStg 32 | import UniqSupply (mkSplitUniqSupply) 33 | 34 | import qualified Data.ByteString.Char8 as BS8 35 | 36 | ------------------------------------------------------------------------------- 37 | -- Utility 38 | ------------------------------------------------------------------------------- 39 | 40 | getDataCon :: Type -> DataCon 41 | getDataCon = tyConSingleDataCon . tyConAppTyCon 42 | 43 | repTy :: PrimRep -> Type 44 | repTy = anyTypeOfKind . tYPE . primRepToRuntimeRep 45 | 46 | mkName :: Int -> String -> Name 47 | mkName i n = mkExternalName (mkUnique 'u' i) modl (mkOccName OccName.varName n) noSrcSpan 48 | 49 | mkIdNT :: Int -> String -> Type -> Id 50 | mkIdNT i n t = mkVanillaGlobal (mkName i n) t 51 | 52 | -- simple ADT Type construction 53 | 54 | simpleDataCon :: TyCon -> Name -> [PrimRep] -> ConTag -> DataCon 55 | simpleDataCon tc name args tag = mkDataCon 56 | name False (error "TyConRepName") [] [] [] [] [] [] [] 57 | (map repTy args) (error "Original result type") (error "RuntimeRepInfo") 58 | tc tag [] fakeWorkerId NoDataConRep 59 | where 60 | fakeWorkerId = mkIdNT 666 "fakeWokerId" (error "repTy LiftedRep") 61 | 62 | simpleTyCon :: Name -> [DataCon] -> TyCon 63 | simpleTyCon name dataCons = mkAlgTyCon name [] (error "Kind") [] Nothing [] (mkDataTyConRhs dataCons) (VanillaAlgTyCon (error "TyConRepName")) False 64 | 65 | ------------------------------------------------------------------------------- 66 | -- Sample STG program 67 | ------------------------------------------------------------------------------- 68 | 69 | {- 70 | - data constructor creation 71 | pattern match 72 | - without parameters 73 | - with parameters 74 | - datacon 75 | - unboxed tuple 76 | unboxed tuple 77 | - return value 78 | - parameter 79 | - bit pattern 80 | - pointer 81 | 82 | HINT 83 | id = unique id 84 | name = unique id + occ name 85 | 86 | CONVENTION: 87 | always use unique occ names 88 | 89 | -} 90 | 91 | {- 92 | unique name spaces in GHC 93 | 0123456789BCDEHLPRSXcdgikmstvz 94 | 95 | used by the stg builder 96 | fu 97 | -} 98 | sampleFFI = do 99 | let dflags = unsafeGlobalDynFlags 100 | mkIdN i n = mkVanillaGlobal (mkName i n) intTy 101 | mkId i = mkVanillaGlobal (mkName i $ 'x' : show i) intTy 102 | idStr0 = mkId 0 103 | idInt0 = mkId 100 104 | idInt1 = mkId 200 105 | topBinds = 106 | [ StgTopStringLit idStr0 (BS8.pack "Hello!\n1 + 2 = %d\n") 107 | , StgTopLifted $ StgNonRec (mkIdN 1 "main") $ 108 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 109 | StgCase ( 110 | StgOpApp (StgPrimOp IntAddOp) 111 | [ StgLitArg $ mkMachInt dflags 1 112 | , StgLitArg $ mkMachInt dflags 2 113 | ] intTy 114 | ) idInt0 (PrimAlt IntRep) 115 | [ (DEFAULT, [], 116 | StgOpApp 117 | (StgFCallOp 118 | (CCall $ CCallSpec 119 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 120 | CCallConv 121 | PlayRisky 122 | ) 123 | (mkUnique 'f' 0) 124 | ) 125 | [ StgVarArg idStr0 126 | , StgVarArg idInt0 127 | ] intTy 128 | ) 129 | ] 130 | ] 131 | compileProgram NCG [] topBinds 132 | 133 | 134 | -- CASE: unboxed tuple immediate decomposition 135 | sampleUnboxedTuple1 = do 136 | let dflags = unsafeGlobalDynFlags 137 | mkIdN i n = mkVanillaGlobal (mkName i n) intTy 138 | mkId i = mkVanillaGlobal (mkName i $ 'x' : show i) intTy 139 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 140 | idStr0 = mkId 0 141 | u2IntTy = mkTupleTy Unboxed [anyTypeOfKind . tYPE . primRepToRuntimeRep $ IntRep, anyTypeOfKind . tYPE . primRepToRuntimeRep $ IntRep] 142 | idInt0 = mkIdT 100 u2IntTy 143 | idInt1 = mkId 200 144 | idInt2 = mkId 202 145 | topBinds = 146 | [ StgTopStringLit idStr0 (BS8.pack "Hello!\n1 + 2 = %d\n") 147 | , StgTopLifted $ StgNonRec (mkIdN 1 "main") $ 148 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 149 | StgCase ( 150 | StgConApp (getDataCon u2IntTy) 151 | [ StgLitArg $ mkMachInt dflags 3 152 | , StgLitArg $ mkMachInt dflags 4 153 | ] [] 154 | ) idInt0 (MultiValAlt 2) 155 | [ (DataAlt (getDataCon u2IntTy), [idInt1, idInt2], 156 | StgOpApp 157 | (StgFCallOp 158 | (CCall $ CCallSpec 159 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 160 | CCallConv 161 | PlayRisky 162 | ) 163 | (mkUnique 'f' 0) 164 | ) 165 | [ StgVarArg idStr0 166 | , StgVarArg idInt2 167 | ] intTy 168 | ) 169 | ] 170 | ] 171 | compileProgram NCG [] topBinds 172 | 173 | -- CASE: unboxed tuple stored in a single variable for later decomposition 174 | sampleUnboxedTuple2 = do 175 | let dflags = unsafeGlobalDynFlags 176 | mkIdN i n = mkVanillaGlobal (mkName i n) intTy 177 | mkId i = mkVanillaGlobal (mkName i $ 'x' : show i) intTy 178 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 179 | idStr0 = mkId 0 180 | u2IntTy = mkTupleTy Unboxed [anyTypeOfKind . tYPE . primRepToRuntimeRep $ IntRep, anyTypeOfKind . tYPE . primRepToRuntimeRep $ IntRep] 181 | idInt0 = mkIdT 100 u2IntTy 182 | idInt01 = mkIdT 101 u2IntTy 183 | idInt1 = mkId 200 184 | idInt2 = mkId 202 185 | topBinds = 186 | [ StgTopStringLit idStr0 (BS8.pack "Hello!\n1 + 2 = %d\n") 187 | , StgTopLifted $ StgNonRec (mkIdN 1 "main") $ 188 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 189 | StgCase ( 190 | StgConApp (tupleDataCon Unboxed 2) 191 | [ StgLitArg $ mkMachInt dflags 3 192 | , StgLitArg $ mkMachInt dflags 4 193 | ] [] 194 | ) idInt0 (MultiValAlt 2) 195 | [ (DEFAULT, [], 196 | 197 | StgCase (StgApp idInt0 []) idInt01 (MultiValAlt 2) 198 | 199 | [ (DataAlt (getDataCon u2IntTy), [idInt1, idInt2], 200 | StgOpApp 201 | (StgFCallOp 202 | (CCall $ CCallSpec 203 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 204 | CCallConv 205 | PlayRisky 206 | ) 207 | (mkUnique 'f' 0) 208 | ) 209 | [ StgVarArg idStr0 210 | , StgVarArg idInt1 211 | ] intTy 212 | ) 213 | ] 214 | ) 215 | ] 216 | ] 217 | 218 | us <- mkSplitUniqSupply 'g' 219 | 220 | compileProgram NCG [] $ unarise us topBinds 221 | 222 | -- CASE: pattern match on Lifted Boxed Tuple 223 | sampleBoxedTuple1 = do 224 | putStrLn "CASE: pattern match on Lifted Boxed Tuple" 225 | let dflags = unsafeGlobalDynFlags 226 | mkIdN i n = mkVanillaGlobal (mkName i n) intTy 227 | mkId i = mkVanillaGlobal (mkName i $ 'x' : show i) intTy 228 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 229 | idStr0 = mkIdT 0 (repTy AddrRep) 230 | idStr1 = mkIdT 1 (repTy AddrRep) 231 | b2IntTy = mkTupleTy Boxed [repTy IntRep, repTy IntRep] 232 | idInt0 = mkIdT 100 (repTy LiftedRep) 233 | idInt01 = mkIdT 101 (repTy LiftedRep) 234 | idInt1 = mkId 200 235 | idInt2 = mkId 202 236 | topBinds = 237 | [ StgTopStringLit idStr0 (BS8.pack "Value: %d\n") 238 | , StgTopStringLit idStr1 (BS8.pack "Value: %d\n") 239 | , StgTopLifted $ StgNonRec (mkIdN 1 "main") $ 240 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 241 | StgCase ( 242 | StgConApp (tupleDataCon Boxed 2) 243 | [ StgLitArg $ mkMachInt dflags 3 244 | , StgLitArg $ mkMachInt dflags 4 245 | ] [] 246 | ) idInt0 PolyAlt 247 | [ (DEFAULT, [], 248 | 249 | StgCase (StgApp idInt0 []) idInt01 (AlgAlt $ tyConAppTyCon b2IntTy) 250 | 251 | [ (DataAlt (getDataCon b2IntTy), [idInt1, idInt2], 252 | StgOpApp 253 | (StgFCallOp 254 | (CCall $ CCallSpec 255 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 256 | CCallConv 257 | PlayRisky 258 | ) 259 | (mkUnique 'f' 0) 260 | ) 261 | [ StgVarArg idStr0 262 | , StgVarArg idInt2 263 | ] intTy 264 | ) 265 | ] 266 | ) 267 | ] 268 | ] 269 | 270 | us <- mkSplitUniqSupply 'g' 271 | 272 | compileProgram NCG [] $ {-unarise us-} topBinds 273 | 274 | -- CASE: pattern match on Unlifted Boxed Tuple 275 | sampleBoxedTuple2 = do 276 | putStrLn "CASE: pattern match on Unlifted Boxed Tuple" 277 | let dflags = unsafeGlobalDynFlags 278 | mkIdN i n = mkVanillaGlobal (mkName i n) intTy 279 | mkId i = mkVanillaGlobal (mkName i $ 'x' : show i) intTy 280 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 281 | idStr0 = mkIdT 0 (repTy AddrRep) 282 | idStr1 = mkIdT 1 (repTy AddrRep) 283 | b2IntTy = mkTupleTy Boxed [repTy IntRep, repTy IntRep] 284 | idInt0 = mkIdT 100 (repTy UnliftedRep) 285 | idInt01 = mkIdT 101 (repTy UnliftedRep) 286 | idInt1 = mkId 200 287 | idInt2 = mkId 202 288 | topBinds = 289 | [ StgTopStringLit idStr0 (BS8.pack "Value: %d\n") 290 | , StgTopStringLit idStr1 (BS8.pack "Value: %d\n") 291 | , StgTopLifted $ StgNonRec (mkIdN 1 "main") $ 292 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 293 | StgCase ( 294 | StgConApp (tupleDataCon Boxed 2) 295 | [ StgLitArg $ mkMachInt dflags 3 296 | , StgLitArg $ mkMachInt dflags 4 297 | ] [] 298 | ) idInt0 PolyAlt 299 | [ (DEFAULT, [], 300 | 301 | StgCase (StgApp idInt0 []) idInt01 (AlgAlt $ tyConAppTyCon b2IntTy) 302 | 303 | [ (DataAlt (getDataCon b2IntTy), [idInt1, idInt2], 304 | StgOpApp 305 | (StgFCallOp 306 | (CCall $ CCallSpec 307 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 308 | CCallConv 309 | PlayRisky 310 | ) 311 | (mkUnique 'f' 0) 312 | ) 313 | [ StgVarArg idStr0 314 | , StgVarArg idInt2 315 | ] intTy 316 | ) 317 | ] 318 | ) 319 | ] 320 | ] 321 | 322 | us <- mkSplitUniqSupply 'g' 323 | 324 | compileProgram NCG [] $ unarise us topBinds 325 | 326 | -- CASE: user ADT Lifted 327 | sampleADT1 = do 328 | putStrLn "CASE: user ADT Lifted" 329 | let dflags = unsafeGlobalDynFlags 330 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 331 | idStr0 = mkIdT 0 (repTy AddrRep) 332 | idStr1 = mkIdT 1 (repTy AddrRep) 333 | idLifted0 = mkIdT 100 (repTy LiftedRep) 334 | idLifted01 = mkIdT 101 (repTy LiftedRep) 335 | dcMyFalse = simpleDataCon tcMyBool (mkName 9001 "MyFalse") [] 2 336 | dcMyTrue = simpleDataCon tcMyBool (mkName 9002 "MyTrue") [] 1 337 | tcMyBool = simpleTyCon (mkName 8001 "MyBool") [dcMyFalse, dcMyTrue] 338 | tyMyBool = mkTyConApp tcMyBool [] 339 | topBinds = 340 | [ StgTopStringLit idStr0 (BS8.pack "Value: MyFalse\n") 341 | , StgTopStringLit idStr1 (BS8.pack "Value: MyTrue\n") 342 | , StgTopLifted $ StgNonRec (mkVanillaGlobal (dataConName dcMyFalse) (repTy LiftedRep)) $ StgRhsCon dontCareCCS dcMyFalse [] 343 | , StgTopLifted $ StgNonRec (mkVanillaGlobal (dataConName dcMyTrue) (repTy LiftedRep)) $ StgRhsCon dontCareCCS dcMyTrue [] 344 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 345 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 346 | StgCase ( 347 | StgConApp dcMyFalse [] (error "StgConApp type list") 348 | ) idLifted0 PolyAlt 349 | [ (DEFAULT, [], 350 | 351 | StgCase (StgApp idLifted0 []) idLifted01 (AlgAlt tcMyBool) 352 | 353 | [ (DataAlt (dcMyTrue), [], 354 | StgOpApp 355 | (StgFCallOp 356 | (CCall $ CCallSpec 357 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 358 | CCallConv 359 | PlayRisky 360 | ) 361 | (mkUnique 'f' 0) 362 | ) 363 | [ StgVarArg idStr1 364 | ] intTy 365 | ) 366 | , (DataAlt (dcMyFalse), [], 367 | StgOpApp 368 | (StgFCallOp 369 | (CCall $ CCallSpec 370 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 371 | CCallConv 372 | PlayRisky 373 | ) 374 | (mkUnique 'f' 0) 375 | ) 376 | [ StgVarArg idStr0 377 | ] intTy 378 | ) 379 | ] 380 | 381 | ) 382 | ] 383 | ] 384 | 385 | us <- mkSplitUniqSupply 'g' 386 | 387 | compileProgram NCG [tcMyBool] $ {-unarise us-} topBinds 388 | 389 | 390 | -- CASE: user ADT Unlifted 391 | sampleADT2 = do 392 | putStrLn "CASE: user ADT Unlifted" 393 | let dflags = unsafeGlobalDynFlags 394 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 395 | idStr0 = mkIdT 0 (repTy AddrRep) 396 | idStr1 = mkIdT 1 (repTy AddrRep) 397 | idUnlifted0 = mkIdT 100 (repTy UnliftedRep) 398 | idUnlifted01 = mkIdT 101 (repTy UnliftedRep) 399 | dcMyFalse = simpleDataCon tcMyBool (mkName 9001 "MyFalse") [] 1 400 | dcMyTrue = simpleDataCon tcMyBool (mkName 9002 "MyTrue") [] 2 401 | tcMyBool = simpleTyCon (mkName 8001 "MyBool") [dcMyFalse, dcMyTrue] 402 | tyMyBool = mkTyConApp tcMyBool [] 403 | topBinds = 404 | [ StgTopStringLit idStr0 (BS8.pack "Value: MyFalse\n") 405 | , StgTopStringLit idStr1 (BS8.pack "Value: MyTrue\n") 406 | , StgTopLifted $ StgNonRec (mkVanillaGlobal (dataConName dcMyFalse) (repTy LiftedRep)) $ StgRhsCon dontCareCCS dcMyFalse [] 407 | , StgTopLifted $ StgNonRec (mkVanillaGlobal (dataConName dcMyTrue) (repTy LiftedRep)) $ StgRhsCon dontCareCCS dcMyTrue [] 408 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 409 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 410 | StgCase ( 411 | StgConApp dcMyTrue [] [] 412 | ) idUnlifted0 PolyAlt 413 | [ (DEFAULT, [], 414 | 415 | StgCase (StgApp idUnlifted0 []) idUnlifted01 (AlgAlt tcMyBool) 416 | 417 | [ (DataAlt (dcMyTrue), [], 418 | StgOpApp 419 | (StgFCallOp 420 | (CCall $ CCallSpec 421 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 422 | CCallConv 423 | PlayRisky 424 | ) 425 | (mkUnique 'f' 0) 426 | ) 427 | [ StgVarArg idStr1 428 | ] intTy 429 | ) 430 | , (DataAlt (dcMyFalse), [], 431 | StgOpApp 432 | (StgFCallOp 433 | (CCall $ CCallSpec 434 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 435 | CCallConv 436 | PlayRisky 437 | ) 438 | (mkUnique 'f' 0) 439 | ) 440 | [ StgVarArg idStr0 441 | ] intTy 442 | ) 443 | ] 444 | 445 | ) 446 | ] 447 | ] 448 | 449 | us <- mkSplitUniqSupply 'g' 450 | 451 | compileProgram NCG [tcMyBool] $ {-unarise us-} topBinds 452 | 453 | -- CASE: user ADT with arguments Lifted 454 | sampleADTArgFloat = do 455 | putStrLn "CASE: user ADT with arguments Lifted" 456 | let dflags = unsafeGlobalDynFlags 457 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 458 | idStr0 = mkIdT 0 (repTy AddrRep) 459 | idStr1 = mkIdT 1 (repTy AddrRep) 460 | id0 = mkIdT 100 (repTy LiftedRep) 461 | id01 = mkIdT 101 (repTy LiftedRep) 462 | dcMyConA = simpleDataCon tcMyADT (mkName 9001 "MyConA") [IntRep, IntRep] 1 463 | dcMyConB = simpleDataCon tcMyADT (mkName 9002 "MyConB") [FloatRep] 2 464 | tcMyADT = simpleTyCon (mkName 8001 "MyADT") [dcMyConA, dcMyConB] 465 | tyMyADT = mkTyConApp tcMyADT [] 466 | idInt1 = mkIdT 200 (repTy IntRep) 467 | idInt2 = mkIdT 202 (repTy IntRep) 468 | id3_f32 = mkIdT 203 (repTy FloatRep) 469 | topBinds = 470 | [ StgTopStringLit idStr0 (BS8.pack "Value: MyConA %d %d\n") 471 | , StgTopStringLit idStr1 (BS8.pack "Value: MyConB %f\n") 472 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 473 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 474 | StgCase ( 475 | 476 | StgConApp dcMyConB 477 | [ StgLitArg $ mkMachFloat 3.14 478 | ] [] 479 | 480 | ) id0 PolyAlt 481 | [ (DEFAULT, [], 482 | 483 | StgCase (StgApp id0 []) id01 (AlgAlt tcMyADT) 484 | 485 | [ (DataAlt (dcMyConA), [idInt1, idInt2], 486 | StgOpApp 487 | (StgFCallOp 488 | (CCall $ CCallSpec 489 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 490 | CCallConv 491 | PlayRisky 492 | ) 493 | (mkUnique 'f' 0) 494 | ) 495 | [ StgVarArg idStr0 496 | , StgVarArg idInt1 497 | , StgVarArg idInt2 498 | ] intTy 499 | ) 500 | , (DataAlt (dcMyConB), [id3_f32], 501 | StgOpApp 502 | (StgFCallOp 503 | (CCall $ CCallSpec 504 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 505 | CCallConv 506 | PlayRisky 507 | ) 508 | (mkUnique 'f' 0) 509 | ) 510 | [ StgVarArg idStr1 511 | , StgVarArg id3_f32 512 | ] intTy 513 | ) 514 | ] 515 | 516 | ) 517 | ] 518 | ] 519 | 520 | us <- mkSplitUniqSupply 'g' 521 | 522 | compileProgram LLVM [tcMyADT] $ {-unarise us-} topBinds 523 | 524 | sampleADTArgDouble = do 525 | putStrLn "CASE: user ADT with arguments Lifted" 526 | let dflags = unsafeGlobalDynFlags 527 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 528 | idStr0 = mkIdT 0 (repTy AddrRep) 529 | idStr1 = mkIdT 1 (repTy AddrRep) 530 | id0 = mkIdT 100 (repTy LiftedRep) 531 | id01 = mkIdT 101 (repTy LiftedRep) 532 | dcMyConA = simpleDataCon tcMyADT (mkName 9001 "MyConA") [IntRep, IntRep] 1 533 | dcMyConB = simpleDataCon tcMyADT (mkName 9002 "MyConB") [DoubleRep] 2 534 | tcMyADT = simpleTyCon (mkName 8001 "MyADT") [dcMyConA, dcMyConB] 535 | tyMyADT = mkTyConApp tcMyADT [] 536 | idInt1 = mkIdT 200 (repTy IntRep) 537 | idInt2 = mkIdT 202 (repTy IntRep) 538 | id3_f64 = mkIdT 203 (repTy DoubleRep) 539 | topBinds = 540 | [ StgTopStringLit idStr0 (BS8.pack "Value: MyConA %d %d\n") 541 | , StgTopStringLit idStr1 (BS8.pack "Value: MyConB %lf\n") 542 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 543 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 544 | StgCase ( 545 | 546 | StgConApp dcMyConB 547 | [ StgLitArg $ mkMachDouble 3.14 548 | ] [] 549 | 550 | ) id0 PolyAlt 551 | [ (DEFAULT, [], 552 | 553 | StgCase (StgApp id0 []) id01 (AlgAlt tcMyADT) 554 | 555 | [ (DataAlt (dcMyConA), [idInt1, idInt2], 556 | StgOpApp 557 | (StgFCallOp 558 | (CCall $ CCallSpec 559 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 560 | CCallConv 561 | PlayRisky 562 | ) 563 | (mkUnique 'f' 0) 564 | ) 565 | [ StgVarArg idStr0 566 | , StgVarArg idInt1 567 | , StgVarArg idInt2 568 | ] intTy 569 | ) 570 | , (DataAlt (dcMyConB), [id3_f64], 571 | StgOpApp 572 | (StgFCallOp 573 | (CCall $ CCallSpec 574 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 575 | CCallConv 576 | PlayRisky 577 | ) 578 | (mkUnique 'f' 0) 579 | ) 580 | [ StgVarArg idStr1 581 | , StgVarArg id3_f64 582 | ] intTy 583 | ) 584 | ] 585 | 586 | ) 587 | ] 588 | ] 589 | 590 | us <- mkSplitUniqSupply 'g' 591 | 592 | compileProgram LLVM [tcMyADT] $ {-unarise us-} topBinds 593 | 594 | -- CASE: user ADT with arguments Unlifted 595 | 596 | {- 597 | QUESTIONS: 598 | - can case bind unboxed tuples to variables for later pattern matching/decomposition? 599 | A: yes, but requires 'unarise' STG pass before codegen 600 | 601 | - which one matter for the codegen, the DataCon tag value or the TyCon's AlgTyConRhs [DataCon] order? 602 | A: only Tag value matters (starting from 1), no order matters (i.e. Case Alt, AlgTyConRhs [DataCon]) 603 | 604 | -} 605 | 606 | -- CASE: FFI float argument 607 | sampleFFIArgFloat = do 608 | putStrLn "CASE: FFI with float argument" 609 | let dflags = unsafeGlobalDynFlags 610 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 611 | topBinds = 612 | [ StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 613 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 614 | StgOpApp 615 | (StgFCallOp 616 | (CCall $ CCallSpec 617 | (StaticTarget NoSourceText (mkFastString "print_float") Nothing True) 618 | CCallConv 619 | PlayRisky 620 | ) 621 | (mkUnique 'f' 0) 622 | ) 623 | [ StgLitArg $ mkMachFloat 3.14 624 | ] intTy 625 | ] 626 | 627 | us <- mkSplitUniqSupply 'g' 628 | 629 | compileProgram NCG [] $ {-unarise us-} topBinds 630 | 631 | -- CASE: FFI double argument 632 | sampleFFIArgDouble = do 633 | putStrLn "CASE: FFI with double argument" 634 | let dflags = unsafeGlobalDynFlags 635 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 636 | topBinds = 637 | [ StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 638 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 639 | StgOpApp 640 | (StgFCallOp 641 | (CCall $ CCallSpec 642 | (StaticTarget NoSourceText (mkFastString "print_double") Nothing True) 643 | CCallConv 644 | PlayRisky 645 | ) 646 | (mkUnique 'f' 0) 647 | ) 648 | [ StgLitArg $ mkMachDouble 3.14 649 | ] intTy 650 | ] 651 | 652 | us <- mkSplitUniqSupply 'g' 653 | 654 | compileProgram NCG [] $ {-unarise us-} topBinds 655 | 656 | -- single value vs unboxed unit ; are they interchangable? 657 | -- CASE: construct Unit# int, unpack prim int 658 | sampleUnboxedUnit1 = do 659 | let dflags = unsafeGlobalDynFlags 660 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 661 | idStr0 = mkIdT 0 (repTy AddrRep) 662 | u1IntTy = mkTupleTy Unboxed [repTy IntRep] 663 | idInt0 = mkIdT 100 (repTy IntRep) 664 | topBinds = 665 | [ StgTopStringLit idStr0 (BS8.pack "Hello!\n1 + 2 = %d\n") 666 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 667 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 668 | StgCase ( 669 | StgConApp (getDataCon u1IntTy) 670 | [ StgLitArg $ mkMachInt dflags 3 671 | ] [] 672 | ) idInt0 (PrimAlt IntRep) 673 | [ (DEFAULT, [], 674 | StgOpApp 675 | (StgFCallOp 676 | (CCall $ CCallSpec 677 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 678 | CCallConv 679 | PlayRisky 680 | ) 681 | (mkUnique 'f' 0) 682 | ) 683 | [ StgVarArg idStr0 684 | , StgVarArg idInt0 685 | ] (repTy VoidRep) 686 | ) 687 | ] 688 | ] 689 | compileProgram NCG [] topBinds 690 | 691 | -- IMPORTANT: binders can not be unboxed tuples 692 | -- CASE: construct prim int, unpack Unit# int into IntRep binder 693 | sampleUnboxedUnit2 = do 694 | let dflags = unsafeGlobalDynFlags 695 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 696 | idStr0 = mkIdT 0 (repTy AddrRep) 697 | utupTy l = mkTupleTy Unboxed $ map repTy l 698 | utupDC = getDataCon . utupTy 699 | idInt0 = mkIdT 100 (utupTy [IntRep]) 700 | idInt1 = mkIdT 101 (repTy IntRep) 701 | topBinds = 702 | [ StgTopStringLit idStr0 (BS8.pack "Hello!\n1 + 2 = %d\n") 703 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 704 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 705 | StgCase ( 706 | StgLit $ mkMachInt dflags 3 707 | ) idInt0 (MultiValAlt 1) 708 | [ (DataAlt (utupDC [IntRep]), [idInt1], 709 | StgOpApp 710 | (StgFCallOp 711 | (CCall $ CCallSpec 712 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 713 | CCallConv 714 | PlayRisky 715 | ) 716 | (mkUnique 'f' 0) 717 | ) 718 | [ StgVarArg idStr0 719 | , StgVarArg idInt1 720 | ] (repTy VoidRep) 721 | ) 722 | ] 723 | ] 724 | compileProgram NCG [] topBinds 725 | 726 | -- IMPORTANT: binders can not be void rep 727 | -- CASE: ffi returns (##) unpack as prim VoidRep [COMPILE ERROR] 728 | sampleUnboxedVoid1 = do 729 | let dflags = unsafeGlobalDynFlags 730 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 731 | idStr0 = mkIdT 0 (repTy AddrRep) 732 | idStr1 = mkIdT 1 (repTy AddrRep) 733 | utupTy l = mkTupleTy Unboxed $ map repTy l 734 | utupDC = getDataCon . utupTy 735 | idVoid0 = mkIdT 100 (utupTy []) 736 | topBinds = 737 | [ StgTopStringLit idStr0 (BS8.pack "Hello!") 738 | , StgTopStringLit idStr1 (BS8.pack "OK!") 739 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 740 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 741 | StgCase ( 742 | 743 | StgOpApp 744 | (StgFCallOp 745 | (CCall $ CCallSpec 746 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 747 | CCallConv 748 | PlayRisky 749 | ) 750 | (mkUnique 'f' 0) 751 | ) 752 | [ StgVarArg idStr0 753 | ] (utupTy []) 754 | 755 | ) idVoid0 (PrimAlt VoidRep) 756 | [ (DEFAULT, [], 757 | 758 | StgOpApp 759 | (StgFCallOp 760 | (CCall $ CCallSpec 761 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 762 | CCallConv 763 | PlayRisky 764 | ) 765 | (mkUnique 'f' 0) 766 | ) 767 | [ StgVarArg idStr1 768 | ] (utupTy []) 769 | 770 | ) 771 | ] 772 | ] 773 | compileProgram NCG [] topBinds 774 | 775 | -- CASE: ffi returns prim VoidRep unpack as (##) with DataAlt + MultiValAlt 0 776 | sampleUnboxedVoid2 = do 777 | let dflags = unsafeGlobalDynFlags 778 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 779 | idStr0 = mkIdT 0 (repTy AddrRep) 780 | idStr1 = mkIdT 1 (repTy AddrRep) 781 | utupTy l = mkTupleTy Unboxed $ map repTy l 782 | utupDC = getDataCon . utupTy 783 | idVoid0 = mkIdT 100 (utupTy []) 784 | topBinds = 785 | [ StgTopStringLit idStr0 (BS8.pack "Hello!\n") 786 | , StgTopStringLit idStr1 (BS8.pack "OK!\n") 787 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 788 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 789 | StgCase ( 790 | 791 | StgOpApp 792 | (StgFCallOp 793 | (CCall $ CCallSpec 794 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 795 | CCallConv 796 | PlayRisky 797 | ) 798 | (mkUnique 'f' 0) 799 | ) 800 | [ StgVarArg idStr0 801 | ] (repTy VoidRep) 802 | 803 | ) idVoid0 (MultiValAlt 0) 804 | [ (DataAlt (utupDC []), [], 805 | 806 | StgOpApp 807 | (StgFCallOp 808 | (CCall $ CCallSpec 809 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 810 | CCallConv 811 | PlayRisky 812 | ) 813 | (mkUnique 'f' 0) 814 | ) 815 | [ StgVarArg idStr1 816 | ] (repTy VoidRep) 817 | 818 | ) 819 | ] 820 | ] 821 | compileProgram NCG [] topBinds 822 | 823 | -- CASE: ffi returns prim VoidRep unpack as (##) with DEFAULT + MultiValAlt 0 824 | sampleUnboxedVoid3 = do 825 | let dflags = unsafeGlobalDynFlags 826 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 827 | idStr0 = mkIdT 0 (repTy AddrRep) 828 | idStr1 = mkIdT 1 (repTy AddrRep) 829 | utupTy l = mkTupleTy Unboxed $ map repTy l 830 | utupDC = getDataCon . utupTy 831 | idVoid0 = mkIdT 100 (utupTy []) 832 | topBinds = 833 | [ StgTopStringLit idStr0 (BS8.pack "Hello!\n") 834 | , StgTopStringLit idStr1 (BS8.pack "OK!\n") 835 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 836 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 837 | StgCase ( 838 | 839 | StgOpApp 840 | (StgFCallOp 841 | (CCall $ CCallSpec 842 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 843 | CCallConv 844 | PlayRisky 845 | ) 846 | (mkUnique 'f' 0) 847 | ) 848 | [ StgVarArg idStr0 849 | ] (repTy VoidRep) 850 | 851 | ) idVoid0 (MultiValAlt 0) 852 | [ (DEFAULT, [], 853 | 854 | StgOpApp 855 | (StgFCallOp 856 | (CCall $ CCallSpec 857 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 858 | CCallConv 859 | PlayRisky 860 | ) 861 | (mkUnique 'f' 0) 862 | ) 863 | [ StgVarArg idStr1 864 | ] (repTy VoidRep) 865 | 866 | ) 867 | ] 868 | ] 869 | compileProgram NCG [] topBinds 870 | 871 | -- CASE: ffi void arg as (##) 872 | sampleUnboxedVoid4 = do 873 | let dflags = unsafeGlobalDynFlags 874 | mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t 875 | idStr0 = mkIdT 0 (repTy AddrRep) 876 | utupTy l = mkTupleTy Unboxed $ map repTy l 877 | utupDC = getDataCon . utupTy 878 | idVoid0 = mkIdT 100 (utupTy []) 879 | topBinds = 880 | [ StgTopStringLit idStr0 (BS8.pack "OK!\n") 881 | , StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $ 882 | StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $ 883 | StgCase ( 884 | 885 | StgConApp (utupDC []) [] [] 886 | 887 | ) idVoid0 (MultiValAlt 0) 888 | [ (DEFAULT, [], 889 | 890 | StgOpApp 891 | (StgFCallOp 892 | (CCall $ CCallSpec 893 | (StaticTarget NoSourceText (mkFastString "printf") Nothing True) 894 | CCallConv 895 | PlayRisky 896 | ) 897 | (mkUnique 'f' 0) 898 | ) 899 | [ StgVarArg idStr0 900 | , StgVarArg idVoid0 901 | , StgVarArg idVoid0 902 | , StgVarArg idVoid0 903 | , StgVarArg idVoid0 904 | ] (repTy VoidRep) 905 | 906 | ) 907 | ] 908 | ] 909 | compileProgram NCG [] topBinds 910 | --------------------------------------------------------------------------------