compiler: fix #370

It uses a singleton struct wrapping around an array
for unboxed arrays

cogent/src/Cogent/C/Expr.hs

@@ -278,7 +278,7 @@ maybeDecl (Just v) t = return (v,[],[])
 
 -- If assigned to a new var, then recycle
 aNewVar :: CType -> CExpr -> VarPool -> Gen v (CExpr, [CBlockItem], [CBlockItem], VarPool)
-aNewVar t e p | __cogent_simpl_cg && not (isTrivialCExpr e)
+aNewVar t e p | not __cogent_simpl_cg && not (isTrivialCExpr e)
   = (extTup3r M.empty) . (first3 variable) <$> declareInit t e p
               | otherwise = return (e,[],[],p)
 
@@ -356,7 +356,7 @@ genExpr mv (TE t (ALit es)) = do
   telt' <- genType telt
   (v,vdecl,vstm) <- maybeDecl mv t'
   blob' <- flip3 zipWithM [0..] blob $ \(e,edecl,estm,ep) idx -> do
-    (adecl,astm) <- assign telt' (mkArrIdx (variable v) idx) e
+    (adecl,astm) <- assign telt' (mkArrIdx (strDot' v arrField) idx) e
     return (edecl++adecl, estm++astm, M.empty)  -- FIXME: varpool - meaningless placeholder now / zilinc
   let (vdecls,vstms,vps) = L.unzip3 blob'
   return (variable v, vdecl ++ concat vdecls, vstm ++ concat vstms, M.empty)
@@ -368,7 +368,7 @@ genExpr mv (TE t (ArrayIndex e i)) = do  -- FIXME: varpool - as above
   let tarr@(TArray telt _ s _) = exprType e
   drexpr <- case s of
     -- unboxed array
-    Unboxed -> return $ CArrayDeref e' i'
+    Unboxed -> return $ CArrayDeref (strDot e' arrField) i'
     -- boxed array of boxed types / boxed array of unboxed types without layout specification
     Boxed _ CLayout -> return $ CArrayDeref e' i'
     -- boxed array of unboxed type
@@ -395,15 +395,15 @@ genExpr mv (TE t (ArrayMap2 (_,f) (e1,e2))) = do  -- FIXME: varpool - as above
   telt2' <- genType telt2
 
   let drexp s e t i = case s of
-                        Unboxed -> return $ CArrayDeref e i
+                        Unboxed -> return $ CArrayDeref (strDot e arrField) i
                         Boxed _ CLayout -> return $ CArrayDeref e i
                         _ -> do f <- genBoxedArrayGetSet t Get
                                 return $ CEFnCall (variable f) [e, i]
   drexp1 <- drexp s1 e1' tarr1 (variable i)
   drexp2 <- drexp s2 e2' tarr2 (variable i)
   (f',fdecl,fstm,fp) <- withBindings (Cons drexp2 (Cons drexp1 Nil)) $ genExpr_ f
   let assdns s et at a i e = case s of
-                               Unboxed -> assign et (CArrayDeref a i) e
+                               Unboxed -> assign et (CArrayDeref (strDot a arrField) i) e
                                Boxed _ CLayout -> assign et (CArrayDeref a i) e
                                _ -> do
                                  f <- genBoxedArrayGetSet at Set
@@ -422,24 +422,31 @@ genExpr mv (TE t (ArrayMap2 (_,f) (e1,e2))) = do  -- FIXME: varpool - as above
           vstm++e1stm++e2stm++istm++[CBIStmt loop]++v1stm++v2stm, M.empty)
 
 genExpr mv (TE t (Pop _ e1 e2)) = do  -- FIXME: varpool - as above
-  -- Idea:
-  --   v :@ vs = e1 in e2 ~~> v1 = e1[0]; t v2[l-1]; v2 = e1[1]; e2
   (e1',e1decl,e1stm,e1p) <- genExpr_ e1
   let t1@(TArray telt l s mhole) = exprType e1  -- ASSERTION: @mhole@ cannot be a hole in its head
-  (v1,v1decl,v1stm,v1p) <- flip3 aNewVar e1p (mkArrIdx e1' 0) =<< genType telt
+  (v1,v1decl,v1stm,v1p) <- flip3 aNewVar e1p (mkArrIdx (strDot e1' arrField) 0) =<< genType telt
   let trest = TArray telt (LOp Minus [l, LILit 1 U32]) s mhole
-  trest' <- genTypeP trest
+  trest' <- genType trest
+  telt'  <- genType telt
   (v2,v2decl,v2stm) <- declare trest'
   -- recycleVars v1p
-  (adecl,astm) <- assign trest' (variable v2) (CBinOp C.Add e1' (mkConst U32 1))
+  -- start a for-loop to copy element-by-element the rest elements in @e1@
+  (i,idecl,istm) <- declareInit u32 (mkConst U32 0) M.empty  -- i = 0;
+  (adecl,astm) <- assign telt' (CArrayDeref (strDot' v2 arrField) (variable i))
+                               (CArrayDeref (strDot e1' arrField) ((CBinOp C.Add (variable i) (mkConst U32 1))))
+                   -- \ ^^^ v2[i] = e1'[i+1]
+  l' <- genLExpr l
+  let cond = CBinOp C.Lt (CBinOp C.Add (variable i) (mkConst U32 1)) l'  -- i + 1 < l
+      inc  = CAssign (variable i) (CBinOp C.Add (variable i) (mkConst U32 1))  -- i++
+      loop = CWhile cond (CBlock $ astm ++ [CBIStmt inc])
   (e2',e2decl,e2stm,e2p) <- withBindings (fromJust $ cvtFromList (SSuc $ SSuc SZero) [v1, variable v2]) $ genExpr mv e2
-  return (e2', e1decl ++ v1decl ++ v2decl ++ adecl ++ e2decl,
-          e1stm ++ v1stm ++ v2stm ++ astm ++ e2stm, e2p)
+  return (e2', e1decl ++ v1decl ++ v2decl ++ idecl ++ adecl ++ e2decl,
+          e1stm ++ v1stm ++ v2stm ++ istm ++ [CBIStmt loop] ++ e2stm, e2p)
 
 genExpr mv (TE t (Singleton e)) = do
   (e',edecl,estm,ep) <- genExpr_ e
   t' <- genType t
-  (v,adecl,astm,vp) <- flip (maybeAssign t' mv) ep $ mkArrIdx e' 0
+  (v,adecl,astm,vp) <- flip (maybeAssign t' mv) ep $ mkArrIdx (strDot e' arrField) 0
   return (v, edecl++adecl, estm++astm, vp)
 
 genExpr mv (TE t (ArrayPut arr i e)) = do
@@ -450,7 +457,7 @@ genExpr mv (TE t (ArrayPut arr i e)) = do
   let (TArray telt _ s _) = t
   telt' <- genType telt
   (assdecl,assstm) <- case s of
-    Unboxed -> assign telt' (CArrayDeref arr' i') e'
+    Unboxed -> assign telt' (CArrayDeref (strDot arr' arrField) i') e'
     Boxed _ CLayout -> assign telt' (CArrayDeref arr' i') e'
     _ -> do
       elemSetter <- genBoxedArrayGetSet t Set
@@ -463,7 +470,7 @@ genExpr mv (TE t (ArrayTake _ arr i e)) = do  -- FIXME: varpool - as above
   (i',idecl,istm,ip) <- genExpr_ i
   let tarr@(TArray telt _ s _) = exprType arr
   drexpr <- case s of
-    Unboxed -> return $ CArrayDeref arr' i'
+    Unboxed -> return $ CArrayDeref (strDot arr' arrField) i'
     Boxed _ CLayout -> return $ CArrayDeref arr' i'
     _ -> do
       elemGetter <- genBoxedArrayGetSet tarr Get
@@ -846,7 +853,7 @@ genDefinition (FunDef attr fn Nil Nil t rt e) = do
   t' <- addSynonym genTypeA (unsafeCoerce t :: CC.Type 'Zero VarName) (argOf fn)
   (e',edecl,estm,_) <- withBindings (Cons (variable arg & if __cogent_funboxed_arg_by_ref then CDeref else id) Nil)
                          (genExpr Nothing (unsafeCoerce e :: TypedExpr 'Zero ('Suc 'Zero) VarName VarName))
-  rt' <- addSynonym genTypeP (unsafeCoerce rt :: CC.Type 'Zero VarName) (retOf fn)
+  rt' <- addSynonym genType (unsafeCoerce rt :: CC.Type 'Zero VarName) (retOf fn)
   funClasses %= M.alter (insertSetMap (fn,attr)) (Function t' rt')
   body <- case __cogent_fintermediate_vars of
     True  -> do (rv,rvdecl,rvstm) <- declareInit rt' e' M.empty
@@ -858,7 +865,7 @@ genDefinition (FunDef attr fn Nil Nil t rt e) = do
                       , CFnDefn (rt',fn) [(t',arg)] body fnspec ]
 genDefinition (AbsDecl attr fn Nil Nil t rt)
   = do t'  <- addSynonym genTypeA (unsafeCoerce t  :: CC.Type 'Zero VarName) (argOf fn)
-       rt' <- addSynonym genTypeP (unsafeCoerce rt :: CC.Type 'Zero VarName) (retOf fn)
+       rt' <- addSynonym genType  (unsafeCoerce rt :: CC.Type 'Zero VarName) (retOf fn)
        funClasses %= M.alter (insertSetMap (fn,attr)) (Function t' rt')
        ffifunc <- if __cogent_fffi_c_functions then genFfiFunc rt' fn [t'] else return []
        return $ ffifunc ++ [CDecl $ CExtFnDecl rt' fn [(t',Nothing)] (fnSpecAttr attr noFnSpec)]

cogent/src/Cogent/C/Syntax.hs

@@ -197,7 +197,7 @@ data StrlType = Record  [(CId, CType)]         -- ^ @(fieldname ↦ fieldty
               | Variant (M.Map CId CType)      -- ^ one tag field, and fields for all possibilities
               | Function CType CType
               | AbsType CId
-              | Array CType
+              | Array CType (Maybe CExpr)      -- for static arrays the size is needed
               | ArrayL (DataLayout BitRange)
               deriving (Eq, Ord, Show, Generic)
 
@@ -381,6 +381,9 @@ boolT, boolField :: CId
 boolT     = "bool_t"
 boolField = "boolean"
 
+arrField :: CId
+arrField = "data"
+
 funEnum fn = "FUN_ENUM_" ++ fn
 untypedFuncEnum = "untyped_func_enum" :: CId
 funDispatch tn = "dispatch_" ++ tn  -- tn is the typename of the Enum

cogent/src/Cogent/C/Type.hs

@@ -112,10 +112,11 @@ genTyDecl (Variant x, n) _ = case __cogent_funion_for_variants of
             [genTySynDecl (n, CStruct n)])
 genTyDecl (Function t1 t2, n) tns =
   if n `elem` tns then ([],[])
-                  else ([], [CDecl $ CTypeDecl (CIdent fty) [n]])
+                  else ([], [genTySynDecl (n, CIdent fty)])
   where fty = if __cogent_funtyped_func_enum then untypedFuncEnum else unitT
 #ifdef BUILTIN_ARRAYS
-genTyDecl (Array t, n) _ = ([CDecl $ CVarDecl t n True Nothing], [])
+genTyDecl (Array t Nothing , n) _ = ([], [genTySynDecl (n, CArray t CPtrToArray   )])
+genTyDecl (Array t (Just e), n) _ = ([], [genTySynDecl (n, CArray t (CArraySize e))])
 genTyDecl (ArrayL layout, n) _ =
   let elemSize = dataLayoutSizeInWords layout
       dataType = CPtr $ CInt False CIntT
@@ -185,7 +186,10 @@ lookupTypeCId (TRecord _ fs (Boxed _ CLayout)) =
     Record <$> (mapM (\(a,(b,_)) -> (a,) <$> (Compose . lookupType) b) fs))
 lookupTypeCId cogentType@(TRecord _ _ (Boxed _ _)) = __impossible "lookupTypeCId: record with non-record layout"
 #ifdef BUILTIN_ARRAYS
-lookupTypeCId (TArray t n Unboxed _) = getCompose (Compose . lookupStrlTypeCId =<< Array <$> (Compose . lookupType) t)
+lookupTypeCId (TArray t n Unboxed _) = do
+  n' <- CArraySize <$> genLExpr n
+  tarr <- getCompose (CArray <$> Compose (lookupType t) <*> Compose (pure $ Just n'))
+  getCompose (Compose . lookupStrlTypeCId =<< (Record . (:[]) . (arrField,)) <$> Compose (pure tarr))
 lookupTypeCId (TArray t n (Boxed _ l) _) = lookupStrlTypeCId (ArrayL l)
 #endif
 lookupTypeCId t = Just <$> typeCId t
@@ -290,11 +294,13 @@ typeCId t = use custTypeGen >>= \ctg ->
 
     typeCId' (TUnit) = return unitT
 #ifdef BUILTIN_ARRAYS
-    typeCId' (TArray t l Unboxed _) = getStrlTypeCId =<< Array <$> genType t
+    typeCId' (TArray t l Unboxed _) = do
+      tarr <- CArray <$> genType t <*> (CArraySize <$> genLExpr l)
+      getStrlTypeCId $ Record [(arrField, tarr)]
     typeCId' (TArray t l (Boxed _ al) _) =
       case al of
         Layout ArrayLayout {} -> getStrlTypeCId (ArrayL al)
-        CLayout -> getStrlTypeCId =<< Array <$> genType t
+        CLayout -> getStrlTypeCId =<< Array <$> genType t <*> pure Nothing
         _ -> __impossible "Tried to get the c-type of an array with a non-array record"
 #endif
 
@@ -353,7 +359,7 @@ genType t@(TArray elt l s _)
   | (Boxed _ CLayout) <- s = CPtr <$> genType elt  -- If it's heap-allocated without layout specified
   -- we get rid of unused info here, e.g. array length, hole location
   | (Boxed _ al)      <- s = CIdent <$> typeCId (simplifyType t) -- we are going to declare it as a type
-  | otherwise              = CArray <$> genType elt <*> (CArraySize <$> genLExpr l)
+  | otherwise              = CIdent <$> typeCId t  -- if the array is unboxed, it's wrapped in a struct
 #endif
 genType t                               = CIdent <$> typeCId t
 
@@ -377,13 +383,6 @@ genTypeA :: CC.Type 'Zero VarName -> Gen v CType
 genTypeA t@(TRecord _ _ Unboxed) | __cogent_funboxed_arg_by_ref = CPtr . CIdent <$> typeCId t  -- TODO: sizeof
 genTypeA t = genType t
 
--- It will generate a pointer type for an array, instead of the static-sized array type
-genTypeP :: CC.Type 'Zero VarName -> Gen v CType
-#ifdef BUILTIN_ARRAYS
-genTypeP (TArray telm l Unboxed _) = CPtr <$> genTypeP telm  -- FIXME: what about boxed? / zilinc
-#endif
-genTypeP t = genType t
-
 
 -- TODO(dagent): this seems wrong with respect to Dargent
 lookupType :: CC.Type 'Zero VarName -> Gen v (Maybe CType)

cogent/tests/tests/ext-array/pass_array-1.cogent

@@ -6,7 +6,9 @@ foo (a,b,cs) = let xs = [a, upcast b, a, upcast b]
 
 caller : () -> ()
 caller _ = let (arr1,arr2) = foo (15,42,[1,3,5])
-           and _ = print arr2
+           and _ = print1 arr1
+           and _ = print2 arr2
             in ()
 
-print : U64#[4] -> ()
+print1 : U64#[3] -> ()
+print2 : U64#[4] -> ()

cogent/tests/tests/ext-array/pass_array-copy-unboxed.cogent

@@ -1,9 +1,6 @@
 foo : U8#[3] -> U8#[3]
 foo x = x
 
-foo' : #{ a : U8, b : U8 } -> #{ a : U8, b : U8 }
-foo' x = x
-
 type A
 
 bar : A#[4] -> A#[4]