Skip to content

Instantly share code, notes, and snippets.

@csabahruska

csabahruska/StgSample.hs

Last active January 22, 2020 10:44
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save csabahruska/e9e143390c863f7b10b0298a7ae80ac1 to your computer and use it in GitHub Desktop.
Save csabahruska/e9e143390c863f7b10b0298a7ae80ac1 to your computer and use it in GitHub Desktop.
Download ZIP
FloatRep vs DoubleRep ADT Argument in STG (GHC 8.6.1 64 bit)
Raw
sampleADTArgDouble.cmm
==================== Raw Cmm ====================
[]
==================== Raw Cmm ====================
[section ""cstring" . :Main.x0_bytes" {
:Main.x0_bytes:
I8[] [86,97,108,117,101,58,32,77,121,67,111,110,65,32,37,100,32,37,100,10]
}]
==================== Raw Cmm ====================
[section ""cstring" . :Main.x1_bytes" {
:Main.x1_bytes:
I8[] [86,97,108,117,101,58,32,77,121,67,111,110,66,32,37,108,102,10]
}]
==================== Raw Cmm ====================
[:Main.main_entry() // []
{ [(cxI8,
:Main.main_info:
const 4294967299;
const 0;
const 14 :: W32;
const 0 :: W32;)]
}
{offset
cxI8: // global
if ((Sp + 8) - 16 < SpLim) (likely: False) goto cxI9; else goto cxIa;
cxIa: // global
Hp = Hp + 16;
if (Hp > HpLim) (likely: False) goto cxIc; else goto cxIb;
cxIc: // global
HpAlloc = 16;
goto cxI9;
cxI9: // global
R1 = :Main.main_closure;
call (stg_gc_fun)(R1) args: 8, res: 0, upd: 8;
cxIb: // global
I64[Hp - 8] = :Main.MyConB_con_info;
F64[Hp] = 3.14 :: W64;
_cxHY::P64 = Hp - 6;
_u1C::P64 = _cxHY::P64;
I64[Sp - 8] = block_cxI2_info;
R1 = _u1C::P64;
Sp = Sp - 8;
call stg_ap_0_fast(R1) args: 8, res: 8, upd: 8;
}
},
section ""data" . :Main.main_closure" {
:Main.main_closure:
const :Main.main_info;
const 0;
},
_cxI2() // [R1]
{ [(cxI2,
block_cxI2_info:
const 0;
const 30 :: W32;
const 0 :: W32;)]
}
{offset
cxI2: // global
_u1D::P64 = R1;
_cxI7::P64 = _u1D::P64 & 7;
switch [1 .. 2] _cxI7::P64 {
case 1 : goto cxI5;
case 2 : goto cxI6;
}
cxI6: // global
_u3h::F64 = F64[_u1D::P64 + 6];
_cxIq::I64 = printf;
_cxIr::I64 = :Main.x1_bytes;
_cxIs::F64 = _u3h::F64;
(_cxIk::P64) = call "ccall" arg hints: [PtrHint,] result hints: [PtrHint] (_cxIq::I64)(_cxIr::I64, _cxIs::F64);
R1 = _cxIk::P64;
Sp = Sp + 8;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
cxI5: // global
_u3e::I64 = I64[_u1D::P64 + 7];
_u3g::I64 = I64[_u1D::P64 + 15];
_cxIm::I64 = printf;
_cxIn::I64 = :Main.x0_bytes;
_cxIo::I64 = _u3e::I64;
_cxIp::I64 = _u3g::I64;
(_cxIg::P64) = call "ccall" arg hints: [PtrHint, ‘signed’,
‘signed’] result hints: [PtrHint] (_cxIm::I64)(_cxIn::I64, _cxIo::I64, _cxIp::I64);
R1 = _cxIg::P64;
Sp = Sp + 8;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
}
}]
==================== Raw Cmm ====================
[section ""cstring" . ixKi_str" {
ixKi_str:
I8[] [109,97,105,110,58,58,77,97,105,110,46,77,121,67,111,110,65]
},
:Main.MyConA_con_entry() // [R1]
{ [(cxKh,
:Main.MyConA_con_info:
const ixKi_str-:Main.MyConA_con_info;
const 8589934592;
const 6 :: W32;
const 0 :: W32;)]
}
{offset
cxKh: // global
R1 = R1 + 1;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
}
}]
==================== Raw Cmm ====================
[section ""cstring" . ixKs_str" {
ixKs_str:
I8[] [109,97,105,110,58,58,77,97,105,110,46,77,121,67,111,110,66]
},
:Main.MyConB_con_entry() // [R1]
{ [(cxKr,
:Main.MyConB_con_info:
const ixKs_str-:Main.MyConB_con_info;
const 4294967296;
const 3 :: W32;
const 1 :: W32;)]
}
{offset
cxKr: // global
R1 = R1 + 2;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
}
}]
Raw
sampleADTArgFloat.cmm
==================== Raw Cmm ====================
[]
==================== Raw Cmm ====================
[section ""cstring" . :Main.x0_bytes" {
:Main.x0_bytes:
I8[] [86,97,108,117,101,58,32,77,121,67,111,110,65,32,37,100,32,37,100,10]
}]
==================== Raw Cmm ====================
[section ""cstring" . :Main.x1_bytes" {
:Main.x1_bytes:
I8[] [86,97,108,117,101,58,32,77,121,67,111,110,66,32,37,102,10]
}]
==================== Raw Cmm ====================
[:Main.main_entry() // []
{ [(cxEo,
:Main.main_info:
const 4294967299;
const 0;
const 14 :: W32;
const 0 :: W32;)]
}
{offset
cxEo: // global
if ((Sp + 8) - 16 < SpLim) (likely: False) goto cxEp; else goto cxEq;
cxEq: // global
Hp = Hp + 16;
if (Hp > HpLim) (likely: False) goto cxEs; else goto cxEr;
cxEs: // global
HpAlloc = 16;
goto cxEp;
cxEp: // global
R1 = :Main.main_closure;
call (stg_gc_fun)(R1) args: 8, res: 0, upd: 8;
cxEr: // global
I64[Hp - 8] = :Main.MyConB_con_info;
F32[Hp] = 3.14 :: W32;
_cxEe::P64 = Hp - 6;
_u1C::P64 = _cxEe::P64;
I64[Sp - 8] = block_cxEi_info;
R1 = _u1C::P64;
Sp = Sp - 8;
call stg_ap_0_fast(R1) args: 8, res: 8, upd: 8;
}
},
section ""data" . :Main.main_closure" {
:Main.main_closure:
const :Main.main_info;
const 0;
},
_cxEi() // [R1]
{ [(cxEi,
block_cxEi_info:
const 0;
const 30 :: W32;
const 0 :: W32;)]
}
{offset
cxEi: // global
_u1D::P64 = R1;
_cxEn::P64 = _u1D::P64 & 7;
switch [1 .. 2] _cxEn::P64 {
case 1 : goto cxEl;
case 2 : goto cxEm;
}
cxEm: // global
_u3h::F32 = F32[_u1D::P64 + 6];
_cxEG::I64 = printf;
_cxEH::I64 = :Main.x1_bytes;
_cxEI::F32 = _u3h::F32;
(_cxEA::P64) = call "ccall" arg hints: [PtrHint,] result hints: [PtrHint] (_cxEG::I64)(_cxEH::I64, _cxEI::F32);
R1 = _cxEA::P64;
Sp = Sp + 8;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
cxEl: // global
_u3e::I64 = I64[_u1D::P64 + 7];
_u3g::I64 = I64[_u1D::P64 + 15];
_cxEC::I64 = printf;
_cxED::I64 = :Main.x0_bytes;
_cxEE::I64 = _u3e::I64;
_cxEF::I64 = _u3g::I64;
(_cxEw::P64) = call "ccall" arg hints: [PtrHint, ‘signed’,
‘signed’] result hints: [PtrHint] (_cxEC::I64)(_cxED::I64, _cxEE::I64, _cxEF::I64);
R1 = _cxEw::P64;
Sp = Sp + 8;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
}
}]
==================== Raw Cmm ====================
[section ""cstring" . ixGy_str" {
ixGy_str:
I8[] [109,97,105,110,58,58,77,97,105,110,46,77,121,67,111,110,65]
},
:Main.MyConA_con_entry() // [R1]
{ [(cxGx,
:Main.MyConA_con_info:
const ixGy_str-:Main.MyConA_con_info;
const 8589934592;
const 6 :: W32;
const 0 :: W32;)]
}
{offset
cxGx: // global
R1 = R1 + 1;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
}
}]
==================== Raw Cmm ====================
[section ""cstring" . ixGI_str" {
ixGI_str:
I8[] [109,97,105,110,58,58,77,97,105,110,46,77,121,67,111,110,66]
},
:Main.MyConB_con_entry() // [R1]
{ [(cxGH,
:Main.MyConB_con_info:
const ixGI_str-:Main.MyConB_con_info;
const 4294967296;
const 3 :: W32;
const 1 :: W32;)]
}
{offset
cxGH: // global
R1 = R1 + 2;
call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
}
}]
Raw
StgSample.hs
module StgSample where
import StgLoopback
-- Compiler
import GHC
import DynFlags
import Outputable
-- Stg Types
import Name
import Id
import Unique
import OccName
import StgSyn
import CostCentre
import ForeignCall
import FastString
import BasicTypes
import CoreSyn (AltCon(..))
import PrimOp
import TysWiredIn
import Literal
import MkId
import Type
import TyCon
import TysPrim
import DataCon
import UnariseStg
import UniqSupply (mkSplitUniqSupply)
import qualified Data.ByteString.Char8 as BS8
-------------------------------------------------------------------------------
-- Utility
-------------------------------------------------------------------------------
mkName :: Int -> String -> Name
mkName i n = mkExternalName (mkUnique 'u' i) modl (mkOccName OccName.varName n) noSrcSpan
repTy :: PrimRep -> Type
repTy = anyTypeOfKind . tYPE . primRepToRuntimeRep
simpleDataCon :: TyCon -> Name -> [PrimRep] -> ConTag -> DataCon
simpleDataCon tc name args tag = mkDataCon
name False (error "TyConRepName") [] [] [] [] [] [] []
(map repTy args) (error "Original result type") (error "RuntimeRepInfo")
tc tag [] fakeWorkerId NoDataConRep
where
fakeWorkerId = mkIdNT 666 "fakeWokerId" (error "repTy LiftedRep")
simpleTyCon :: Name -> [DataCon] -> TyCon
simpleTyCon name dataCons = mkAlgTyCon name [] (error "Kind") [] Nothing [] (mkDataTyConRhs dataCons) (VanillaAlgTyCon (error "TyConRepName")) False
mkIdNT i n t = mkVanillaGlobal (mkName i n) t
-------------------------------------------------------------------------------
-- Sample STG program
-------------------------------------------------------------------------------
-- CASE: user Lifted ADT with arguments
sampleADTArgFloat = do
putStrLn "CASE: user Lifted ADT with arguments"
let dflags = unsafeGlobalDynFlags
mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t
idStr0 = mkIdT 0 (repTy AddrRep)
idStr1 = mkIdT 1 (repTy AddrRep)
id0 = mkIdT 100 (repTy LiftedRep)
id01 = mkIdT 101 (repTy LiftedRep)
dcMyConA = simpleDataCon tcMyADT (mkName 9001 "MyConA") [IntRep, IntRep] 1
dcMyConB = simpleDataCon tcMyADT (mkName 9002 "MyConB") [FloatRep] 2
tcMyADT = simpleTyCon (mkName 8001 "MyADT") [dcMyConA, dcMyConB]
tyMyADT = mkTyConApp tcMyADT []
idInt1 = mkIdT 200 (repTy IntRep)
idInt2 = mkIdT 202 (repTy IntRep)
id3_f32 = mkIdT 203 (repTy FloatRep)
topBinds =
[ StgTopStringLit idStr0 (BS8.pack "Value: MyConA %d %d\n")
, StgTopStringLit idStr1 (BS8.pack "Value: MyConB %f\n")
, StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $
StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $
StgCase (
StgConApp dcMyConB
[ StgLitArg $ mkMachFloat 3.14
] []
) id0 PolyAlt
[ (DEFAULT, [],
StgCase (StgApp id0 []) id01 (AlgAlt tcMyADT)
[ (DataAlt (dcMyConA), [idInt1, idInt2],
StgOpApp
(StgFCallOp
(CCall $ CCallSpec
(StaticTarget NoSourceText (mkFastString "printf") Nothing True)
CCallConv
PlayRisky
)
(mkUnique 'f' 0)
)
[ StgVarArg idStr0
, StgVarArg idInt1
, StgVarArg idInt2
] intTy
)
, (DataAlt (dcMyConB), [id3_f32],
StgOpApp
(StgFCallOp
(CCall $ CCallSpec
(StaticTarget NoSourceText (mkFastString "printf") Nothing True)
CCallConv
PlayRisky
)
(mkUnique 'f' 0)
)
[ StgVarArg idStr1
, StgVarArg id3_f32
] intTy
)
]
)
]
]
us <- mkSplitUniqSupply 'g'
compileProgram LLVM [tcMyADT] $ {-unarise us-} topBinds
sampleADTArgDouble = do
putStrLn "CASE: user Lifted ADT with arguments"
let dflags = unsafeGlobalDynFlags
mkIdT i t = mkVanillaGlobal (mkName i $ 'x' : show i) t
idStr0 = mkIdT 0 (repTy AddrRep)
idStr1 = mkIdT 1 (repTy AddrRep)
id0 = mkIdT 100 (repTy LiftedRep)
id01 = mkIdT 101 (repTy LiftedRep)
dcMyConA = simpleDataCon tcMyADT (mkName 9001 "MyConA") [IntRep, IntRep] 1
dcMyConB = simpleDataCon tcMyADT (mkName 9002 "MyConB") [DoubleRep] 2
tcMyADT = simpleTyCon (mkName 8001 "MyADT") [dcMyConA, dcMyConB]
tyMyADT = mkTyConApp tcMyADT []
idInt1 = mkIdT 200 (repTy IntRep)
idInt2 = mkIdT 202 (repTy IntRep)
id3_f64 = mkIdT 203 (repTy DoubleRep)
topBinds =
[ StgTopStringLit idStr0 (BS8.pack "Value: MyConA %d %d\n")
, StgTopStringLit idStr1 (BS8.pack "Value: MyConB %lf\n")
, StgTopLifted $ StgNonRec (mkIdNT 1 "main" $ repTy LiftedRep) $
StgRhsClosure dontCareCCS {-stgSatOcc-} stgUnsatOcc [] {-SingleEntry-}Updatable [voidArgId] $
StgCase (
StgConApp dcMyConB
[ StgLitArg $ mkMachDouble 3.14
] []
) id0 PolyAlt
[ (DEFAULT, [],
StgCase (StgApp id0 []) id01 (AlgAlt tcMyADT)
[ (DataAlt (dcMyConA), [idInt1, idInt2],
StgOpApp
(StgFCallOp
(CCall $ CCallSpec
(StaticTarget NoSourceText (mkFastString "printf") Nothing True)
CCallConv
PlayRisky
)
(mkUnique 'f' 0)
)
[ StgVarArg idStr0
, StgVarArg idInt1
, StgVarArg idInt2
] intTy
)
, (DataAlt (dcMyConB), [id3_f64],
StgOpApp
(StgFCallOp
(CCall $ CCallSpec
(StaticTarget NoSourceText (mkFastString "printf") Nothing True)
CCallConv
PlayRisky
)
(mkUnique 'f' 0)
)
[ StgVarArg idStr1
, StgVarArg id3_f64
] intTy
)
]
)
]
]
us <- mkSplitUniqSupply 'g'
compileProgram LLVM [tcMyADT] $ {-unarise us-} topBinds
@csabahruska
Copy link
Author

csabahruska commented Jan 22, 2020 •
edited

The StgSample module builds two small STG AST that are passed to GHC codegen to generate executable.
Both sampleADTArgFloat and sampleADTArgDouble is intended to output: Value: MyConB 3.140000

Problem / Output:
sampleADTArgDouble: Value: MyConB 3.140000
sampleADTArgFloat: Value: MyConB 0.000000

The generated Cmm output is included for the two samples.

See the full source code here.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment