[unbox strict fields of data constructors
John Meacham <john@repetae.net>**20061219051427] hunk ./DataConstructors.hs 7
+    Slot(..),
hunk ./DataConstructors.hs 27
+    slotTypesHs,
hunk ./DataConstructors.hs 32
+    conSlots,
hunk ./DataConstructors.hs 131
-    conName     :: Name,         -- name of constructor
-    conType     :: E,            -- type of constructor
-    conExpr     :: E,            -- expression which constructs this value
-    conSlots    :: [E],          -- slots
-    conDeriving :: [Name],       -- classes this type derives
-    conAlias    :: AliasType,    -- whether this is a simple alias and has no tag of its own.
-    conInhabits :: Name,         -- what constructor it inhabits, similar to conType, but not quite.
-    conVirtual  :: Maybe [Name], -- whether this is a virtual constructor that translates into an enum and its siblings
-    conChildren :: DataFamily
+    conName      :: Name,        -- name of constructor
+    conType      :: E,            -- type of constructor
+    conExpr      :: E,            -- expression which constructs this value
+    conOrigSlots :: [Slot],      -- original slots
+    conDeriving  :: [Name],       -- classes this type derives
+    conAlias     :: AliasType,    -- whether this is a simple alias and has no tag of its own.
+    conInhabits  :: Name,        -- what constructor it inhabits, similar to conType, but not quite.
+    conVirtual   :: Maybe [Name], -- whether this is a virtual constructor that translates into an enum and its siblings
+    conChildren  :: DataFamily
hunk ./DataConstructors.hs 143
+data Slot =
+    SlotNormal E
+    | SlotUnpacked E !Name [E]
+    | SlotExistential TVr
+    deriving(Eq,Ord,Show)
+    {-! derive: GhcBinary !-}
+
+mapESlot f (SlotExistential t) = SlotExistential t { tvrType = f (tvrType t) }
+mapESlot f (SlotNormal e) = SlotNormal $ f e
+mapESlot f (SlotUnpacked e n es) = SlotUnpacked (f e) n (map f es)
+
+conSlots s = getSlots $ conOrigSlots s
+
+getSlots ss = concatMap f ss where
+    f (SlotNormal e) = [e]
+    f (SlotUnpacked _ _ es) = es
+    f (SlotExistential e) = [tvrType e]
+
+getHsSlots ss = map f ss where
+    f (SlotNormal e) = e
+    f (SlotUnpacked e _ es) = e
+    f (SlotExistential e) = tvrType e
+
+origSlots = map SlotNormal
+
hunk ./DataConstructors.hs 176
-                conSlots = [],
+                conOrigSlots = [],
hunk ./DataConstructors.hs 209
-            conSlots = map EVar typeVars,
+            conOrigSlots = map (SlotNormal . EVar) typeVars,
hunk ./DataConstructors.hs 211
-            conInhabits = tc,
-            conChildren = DataNone
+            conInhabits = tc
hunk ./DataConstructors.hs 216
-            conSlots = replicate n eStar,
+            conOrigSlots = replicate n (SlotNormal eStar),
hunk ./DataConstructors.hs 234
-            conInhabits = tStar,
-            conChildren = DataNone
+            conInhabits = tStar
hunk ./DataConstructors.hs 254
-            conSlots = [eStar,eStar],
+            conOrigSlots = [SlotNormal eStar,SlotNormal eStar],
hunk ./DataConstructors.hs 274
-            conSlots = [rt],
+            conOrigSlots = [SlotNormal rt],
hunk ./DataConstructors.hs 276
-            conInhabits = tc,
-            conChildren = DataNone
+            conInhabits = tc
hunk ./DataConstructors.hs 335
-            Constructor { conSlots = [st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable
+            Constructor { conOrigSlots = [SlotNormal st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable
hunk ./DataConstructors.hs 352
-            Constructor { conSlots = [st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable
+            Constructor { conOrigSlots = [SlotNormal st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable
hunk ./DataConstructors.hs 375
-          Just Constructor { conSlots = [st@(ELit LitCons { litName = n, litArgs = [], litType = _ })] } <- getConstructor cn dataTable
+          Just Constructor { conOrigSlots = [SlotNormal st@(ELit LitCons { litName = n, litArgs = [], litType = _ })] } <- getConstructor cn dataTable
hunk ./DataConstructors.hs 434
-        Constructor { conChildren = DataNormal [x], conSlots = cs } <- getConstructor n dataTable
-        Constructor { conAlias = ErasedAlias, conSlots = [sl] } <- getConstructor x dataTable
-        return (foldr ELam sl [ tVr i s | s <- cs | i <- [2,4..]])
+        Constructor { conChildren = DataNormal [x], conOrigSlots = cs } <- getConstructor n dataTable
+        Constructor { conAlias = ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable
+        return (foldr ELam sl [ tVr i s | s <- getSlots cs | i <- [2,4..]])
hunk ./DataConstructors.hs 452
-    procNewTypes c = c { conExpr = f (conExpr c), conType = f (conType c), conSlots = map f (conSlots c) } where
-        f = removeNewtypes (newDataTable `mappend` currentDataTable)
+    fullDataTable = (newDataTable `mappend` currentDataTable)
+    procNewTypes c = c { conExpr = f (conExpr c), conType = f (conType c), conOrigSlots = map (mapESlot f) (conOrigSlots c) } where
+        f = removeNewtypes fullDataTable
hunk ./DataConstructors.hs 475
-            dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conSlots = [rtype], conExpr = ELam (tVr 12 rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr 12 rtype)], litType =  conExpr theType })) }
+            dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr 12 rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr 12 rtype)], litType =  conExpr theType })) }
hunk ./DataConstructors.hs 494
+
hunk ./DataConstructors.hs 499
-            conSlots =  slots,
+            conOrigSlots = origSlots,
hunk ./DataConstructors.hs 502
-            conAlias = alias,
-            conChildren = DataNone
+            conAlias = alias
hunk ./DataConstructors.hs 504
-        theExpr =  foldr ($) (strictize $ ELit litCons { litName = dataConsName, litArgs = map EVar vars, litType = theTypeExpr }) (map ELam vars)
-        slots = map (subst . tvrType) ts -- XXX TODO fix this mapping
-        vars = [ tvr { tvrType = t } | tvr <- ts | t <- slots ]
-        strictize con = E.Subst.subst tvr { tvrIdent = -1 } Unknown $ f (zip (map isHsBangedTy args) vars) con where
-            f ((False,_):rs) con = f rs con
-            f ((True,var):rs) con = eStrictLet var (EVar var) (f rs con)
-            f [] con = con
hunk ./DataConstructors.hs 505
-        args = hsConDeclArgs x
-        (ELit LitCons { litName = _, litArgs = xs, litType = _ } ,ts') = fromPi $ runVarName $ do
-            flip mapM_ vs $ \tv -> do
-                newName [2,4..] () tv
+
+        theExpr =  foldr ELam (strictize tslots $ ELit litCons { litName = dataConsName, litArgs = map EVar dvars, litType = theTypeExpr }) hsvars
+
+        strictize tslots con = E.Subst.subst tvr { tvrIdent = -1 } Unknown $ f tslots con where
+            f (Left (v,False):rs) con = f rs con
+            f (Left (v,True):rs) con = eStrictLet v (EVar v) (f rs con)
+            f (Right (v,dc,rcs):rs) con = eCase (EVar v) [Alt pat (f rs con)] Unknown where
+                pat = litCons { litName = dc, litArgs = rcs, litType = (getType v) }
+            f [] con = con
+
+        -- substitution is only about substituting type variables
+        (ELit LitCons { litArgs = thisTypeArgs }, origArgs) = fromPi $ runVarName $ do
+            let (vs,ty) = case Map.lookup dataConsName cm of Just (TForAll vs (_ :=> ty)) -> (vs,ty); Just ty -> ([],ty)
+            mapM_ (newName [2,4..] ()) vs
hunk ./DataConstructors.hs 520
-        existentials = melems $ freeVars (map getType ts') S.\\ (freeVars xs :: IdMap TVr)
-        subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- xs | p <- [2,4..] ]
-        ts = existentials ++ [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length theTypeArgs) [2,4..] ]
-        (vs,ty) = case Map.lookup dataConsName cm of
-            Just (TForAll vs (_ :=> ty)) -> (vs,ty)
-            Just ty -> ([],ty)
+        subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- [2,4..] ]
+
+        origSlots = map SlotExistential existentials ++ map f tslots where
+            f (Left (e,_)) = SlotNormal (getType e)
+            f (Right (e,n,es)) = SlotUnpacked (getType e) n (map getType es)
+        hsvars = existentials ++ map f tslots where
+            f (Left (e,_)) = e
+            f (Right (e,_,_)) = e
+        dvars = existentials ++ concatMap f tslots where
+            f (Left (e,_)) = [e]
+            f (Right (_,_,es)) = es
+        tslots = f (newIds fvset) (map isHsBangedTy (hsConDeclArgs x)) origArgs where
+            f (i:is) (False:bs) (e:es) = Left (e { tvrIdent = i, tvrType = subst (tvrType e) },False):f is bs es
+            f (i:j:is) (True:bs) (e:es) = maybe  (Left (e { tvrIdent = i, tvrType = subst (tvrType e) },True):f is bs es) id $ do
+                ELit LitCons { litName = n } <- return $ followAliases fullDataTable (getType e)
+                Constructor { conChildren = DataNormal [dc] } <- getConstructor n fullDataTable
+                [st] <- return $ slotTypes fullDataTable dc (tvrType e)
+                let nv = tvr { tvrIdent = j, tvrType = st }
+                return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es
+            f _ [] [] = []
+            fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList [2,4 .. 2 * (length theTypeArgs + 2)]
+
+        -- existentials are free variables in the arguments, that arn't bound in the type
+        existentials = melems $ freeVars (map getType origArgs) S.\\ (freeVars thisTypeArgs :: IdMap TVr)
+
+        -- arguments that the front end passes or pulls out of this constructor
+        hsArgs = existentials ++ [ tvr {tvrIdent = x} | tvr <- origArgs | x <- drop (5 + length theTypeArgs) [2,4..] ]
+
+
+
hunk ./DataConstructors.hs 559
-            conSlots = map tvrType theTypeArgs,
+            conOrigSlots = map (SlotNormal . tvrType) theTypeArgs,
hunk ./DataConstructors.hs 594
-    DataTable -- ^ table of data constructors
+    UniqueProducer m
+    => DataTable -- ^ table of data constructors
hunk ./DataConstructors.hs 599
-    -> [TVr]  -- ^ name supply, types ignored, must be at least as many as bound variables exist
hunk ./DataConstructors.hs 600
-    -> Alt E  -- ^ resulting alternative
-deconstructionExpression dataTable name typ@(ELit LitCons { litName = pn, litArgs = xs, litType = _ }) vs _vs' e | pn == conName pc = ans where
+    -> m (Alt E)  -- ^ resulting alternative
+deconstructionExpression dataTable name typ@(ELit LitCons { litName = pn, litArgs = xs }) vs  e | pn == conName pc = ans where
hunk ./DataConstructors.hs 605
-        Nothing -> Alt (litCons { litName = name, litArgs = vs, litType = typ }) e
-        Just _ -> let ELit LitCons {  litArgs = [ELit (LitInt n t)] } = conExpr mc in Alt (LitInt n t) e
-deconstructionExpression wdt n ty vs vs' e | Just fa <- followAlias wdt ty  = deconstructionExpression wdt n fa vs vs' e
-deconstructionExpression _ n e _ _ _ = error $ "deconstructionExpression: error in " ++ show n ++ ": " ++ show e
+        Just _ -> return $ let ELit LitCons {  litArgs = [ELit (LitInt n t)] } = conExpr mc in Alt (LitInt n t) e
+        Nothing -> do
+            let f vs (SlotExistential t:ss) rs ls = f vs ss (t:rs) ls
+                f (v:vs) (SlotNormal e:ss) rs ls = f vs ss (v:rs) ls
+                f (v:vs) (SlotUnpacked e n es:ss) rs ls = do
+                    let g t = do
+                            s <- newUniq
+                            return $ tVr (2*s) t
+                    as <- mapM g es
+                    f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = e }):ls)
+                f [] [] rs ls = return $ Alt (litCons { litName = name, litArgs = reverse rs, litType = typ }) (eLetRec ls e)
+            f vs (conOrigSlots mc) [] []
+deconstructionExpression wdt n ty vs e | Just fa <- followAlias wdt ty  = deconstructionExpression wdt n fa vs e
+deconstructionExpression _ n e _ _ = error $ "deconstructionExpression: error in " ++ show n ++ ": " ++ show e
hunk ./DataConstructors.hs 637
+slotTypesHs ::
+    DataTable -- ^ table of data constructors
+    -> Name   -- ^ name of constructor
+    -> E      -- ^ type of value
+    -> [E]    -- ^ type of each slot
+slotTypesHs wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ })
+    | pn == conName pc = [sub x | x <- getHsSlots $ conOrigSlots mc ]
+    where
+    Identity mc = getConstructor n wdt
+    Identity pc = getConstructor (conInhabits mc) wdt
+    sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- [2,4..] ]
+slotTypesHs wdt n kind
+    | sortKindLike kind, (e,ts) <- fromPi kind = drop (length ts) (conSlots mc)
+    where Identity mc = getConstructor n wdt
+slotTypesHs wdt n e | Just fa <- followAlias wdt e  = slotTypes wdt n fa
+slotTypesHs _ n e = error $ "slotTypes: error in " ++ show n ++ ": " ++ show e
+
hunk ./E/FromHs.hs 785
-                        vs <- newVars (slotTypes dataTable (toName DataConstructor name) (getType b))
-                        vs' <- newVars (map (const Unknown) vs)
-
+                        vs <- newVars (slotTypesHs dataTable (toName DataConstructor name) (getType b))
hunk ./E/FromHs.hs 788
-                        return $ deconstructionExpression dataTable (toName DataConstructor name) (getType b) vs vs' m
+                        deconstructionExpression dataTable (toName DataConstructor name) (getType b) vs m
hunk ./E/FromHs.hs 796
-                            (Just Constructor { conSlots = [rtype] }) = getConstructor vCons dataTable
+                            (Just Constructor { conOrigSlots = [SlotNormal rtype] }) = getConstructor vCons dataTable